diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -26,7 +26,7 @@
 
         Arity, RepArity, JoinArity,
 
-        Alignment,
+        Alignment, mkAlignment, alignmentOf, alignmentBytes,
 
         PromotionFlag(..), isPromoted,
         FunctionOrData(..),
@@ -116,6 +116,7 @@
 import SrcLoc ( Located,unLoc )
 import Data.Data hiding (Fixity, Prefix, Infix)
 import Data.Function (on)
+import Data.Bits
 
 {-
 ************************************************************************
@@ -196,8 +197,39 @@
 ************************************************************************
 -}
 
-type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
+-- | A power-of-two alignment
+newtype Alignment = Alignment { alignmentBytes :: Int } deriving (Eq, Ord)
 
+-- Builds an alignment, throws on non power of 2 input. This is not
+-- ideal, but convenient for internal use and better then silently
+-- passing incorrect data.
+mkAlignment :: Int -> Alignment
+mkAlignment n
+  | n == 1 = Alignment 1
+  | n == 2 = Alignment 2
+  | n == 4 = Alignment 4
+  | n == 8 = Alignment 8
+  | n == 16 = Alignment 16
+  | n == 32 = Alignment 32
+  | n == 64 = Alignment 64
+  | n == 128 = Alignment 128
+  | n == 256 = Alignment 256
+  | n == 512 = Alignment 512
+  | otherwise = panic "mkAlignment: received either a non power of 2 argument or > 512"
+
+-- Calculates an alignment of a number. x is aligned at N bytes means
+-- the remainder from x / N is zero. Currently, interested in N <= 8,
+-- but can be expanded to N <= 16 or N <= 32 if used within SSE or AVX
+-- context.
+alignmentOf :: Int -> Alignment
+alignmentOf x = case x .&. 7 of
+  0 -> Alignment 8
+  4 -> Alignment 4
+  2 -> Alignment 2
+  _ -> Alignment 1
+
+instance Outputable Alignment where
+  ppr (Alignment m) = ppr m
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -166,9 +166,6 @@
 -----------------------------------------------------------------------------
 
 data Width   = W8 | W16 | W32 | W64
-             | W80      -- Extended double-precision float,
-                        -- used in x86 native codegen only.
-                        -- (we use Ord, so it'd better be in this order)
              | W128
              | W256
              | W512
@@ -185,9 +182,9 @@
 mrStr W128 = sLit("W128")
 mrStr W256 = sLit("W256")
 mrStr W512 = sLit("W512")
-mrStr W80  = sLit("W80")
 
 
+
 -------- Common Widths  ------------
 wordWidth :: DynFlags -> Width
 wordWidth dflags
@@ -222,8 +219,8 @@
 widthInBits W128 = 128
 widthInBits W256 = 256
 widthInBits W512 = 512
-widthInBits W80  = 80
 
+
 widthInBytes :: Width -> Int
 widthInBytes W8   = 1
 widthInBytes W16  = 2
@@ -232,8 +229,8 @@
 widthInBytes W128 = 16
 widthInBytes W256 = 32
 widthInBytes W512 = 64
-widthInBytes W80  = 10
 
+
 widthFromBytes :: Int -> Width
 widthFromBytes 1  = W8
 widthFromBytes 2  = W16
@@ -242,7 +239,7 @@
 widthFromBytes 16 = W128
 widthFromBytes 32 = W256
 widthFromBytes 64 = W512
-widthFromBytes 10 = W80
+
 widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)
 
 -- log_2 of the width in bytes, useful for generating shifts.
@@ -254,7 +251,7 @@
 widthInLog W128 = 4
 widthInLog W256 = 5
 widthInLog W512 = 6
-widthInLog W80  = panic "widthInLog: F80"
+
 
 -- widening / narrowing
 
diff --git a/compiler/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c
deleted file mode 100644
--- a/compiler/ghci/keepCAFsForGHCi.c
+++ /dev/null
@@ -1,15 +0,0 @@
-#include "Rts.h"
-
-// This file is only included in the dynamic library.
-// It contains an __attribute__((constructor)) function (run prior to main())
-// which sets the keepCAFs flag in the RTS, before any Haskell code is run.
-// This is required so that GHCi can use dynamic libraries instead of HSxyz.o
-// files.
-
-static void keepCAFsForGHCi(void) __attribute__((constructor));
-
-static void keepCAFsForGHCi(void)
-{
-    keepCAFs = 1;
-}
-
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -105,14 +105,22 @@
 type LBangType pass = Located (BangType pass)
 
 -- | Bang Type
+--
+-- In the parser, strictness and packedness annotations bind more tightly
+-- than docstrings. This means that when consuming a 'BangType' (and looking
+-- for 'HsBangTy') we must be ready to peer behind a potential layer of
+-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.
 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 _ _ lty))       = lty
+getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
+  addCLoc lty lds (HsDocTy x lty lds)
+getBangType lty                                            = lty
 
 getBangStrictness :: LHsType a -> HsSrcBang
-getBangStrictness (L _ (HsBangTy _ s _)) = s
+getBangStrictness                 (L _ (HsBangTy _ s _))     = s
+getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s
 getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
 
 {-
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -106,7 +106,7 @@
 import RdrName
 import Var
 import TyCoRep
-import Type   ( tyConArgFlags )
+import Type   ( appTyArgFlags, splitAppTys, tyConArgFlags )
 import TysWiredIn ( unitTy )
 import TcType
 import DataCon
@@ -665,7 +665,6 @@
                           , 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 NoExt (HsNumTy NoSourceText n)
     go (LitTy (StrTyLit s))
@@ -674,26 +673,34 @@
       | tyConAppNeedsKindSig True tc (length args)
         -- We must produce an explicit kind signature here to make certain
         -- programs kind-check. See Note [Kind signatures in typeToLHsType].
-      = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))
-      | otherwise = lhs_ty
+      = nlHsParTy $ noLoc $ HsKindSig NoExt ty' (go (tcTypeKind ty))
+      | otherwise = ty'
        where
-        arg_flags :: [ArgFlag]
-        arg_flags = tyConArgFlags tc args
-
-        lhs_ty :: LHsType GhcPs
-        lhs_ty = foldl' (\f (arg, flag) ->
-                          let arg' = go arg in
-                          case flag of
-                            Inferred  -> f
-                            Specified -> f `nlHsAppKindTy` arg'
-                            Required  -> f `nlHsAppTy`     arg')
-                        (nlHsTyVar (getRdrName tc))
-                        (zip args arg_flags)
+        ty' :: LHsType GhcPs
+        ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args)
+    go ty@(AppTy {})        = go_app (go head) args (appTyArgFlags head args)
+      where
+        head :: Type
+        args :: [Type]
+        (head, args) = splitAppTys ty
     go (CastTy ty _)        = go ty
     go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)
 
          -- Source-language types have _invisible_ kind arguments,
          -- so we must remove them here (#8563)
+
+    go_app :: LHsType GhcPs -- The type being applied
+           -> [Type]        -- The argument types
+           -> [ArgFlag]     -- The argument types' visibilities
+           -> LHsType GhcPs
+    go_app head args arg_flags =
+      foldl' (\f (arg, flag) ->
+               let arg' = go arg in
+               case flag of
+                 Inferred  -> f
+                 Specified -> f `nlHsAppKindTy` arg'
+                 Required  -> f `nlHsAppTy`     arg')
+             head (zip args arg_flags)
 
     go_tv :: TyVar -> LHsTyVarBndr GhcPs
     go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -1034,7 +1034,7 @@
     -- a compound field type is if it's preceded by a bang pattern.
     pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty
     -- If not using record syntax, a compound field type might need to be
-    -- parenthesize if one of the following holds:
+    -- parenthesized if one of the following holds:
     --
     -- 1. We're using Haskell98 syntax.
     -- 2. The field type is preceded with a bang pattern.
@@ -1046,18 +1046,23 @@
     -- If we're displaying the fields GADT-style, e.g.,
     --
     --   data Foo a where
-    --     MkFoo :: Maybe a -> Foo
+    --     MkFoo :: (Int -> Int) -> Maybe a -> Foo
     --
-    -- Then there is no inherent need to parenthesize compound fields like
-    -- `Maybe a` (bang patterns notwithstanding). If we're displaying the
-    -- fields Haskell98-style, e.g.,
+    -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the
+    -- parentheses that it requires, but simple compound types like `Maybe a`
+    -- (which don't require parentheses in a function argument position) won't
+    -- get them, assuming that there are no bang patterns (see bang_prec).
     --
-    --   data Foo a = MkFoo (Maybe a)
+    -- If we're displaying the fields Haskell98-style, e.g.,
     --
-    -- Then we *must* parenthesize compound fields like (Maybe a).
+    --   data Foo a = MkFoo (Int -> Int) (Maybe a)
+    --
+    -- Then not only must we parenthesize `Int -> Int`, we must also
+    -- parenthesize compound fields like (Maybe a). Therefore, we pick
+    -- `appPrec`, which has higher precedence than `funPrec`.
     gadt_prec :: PprPrec
     gadt_prec
-      | gadt_style = topPrec
+      | gadt_style = funPrec
       | otherwise  = appPrec
 
     -- The presence of bang patterns or UNPACK annotations requires
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -369,4 +369,3 @@
 isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
 isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)
 isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)
-
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -41,6 +41,7 @@
         whenGeneratingDynamicToo, ifGeneratingDynamicToo,
         whenCannotGenerateDynamicToo,
         dynamicTooMkDynamicDynFlags,
+        dynamicOutputFile,
         DynFlags(..),
         FlagSpec(..),
         HasDynFlags(..), ContainsDynFlags(..),
@@ -58,7 +59,7 @@
         fFlags, fLangFlags, xFlags,
         wWarningFlags,
         dynFlagDependencies,
-        tablesNextToCode, mkTablesNextToCode,
+        tablesNextToCode,
         makeDynFlagsConsistent,
         shouldUseColor,
         shouldUseHexWordLiterals,
@@ -92,7 +93,8 @@
         extraGccViaCFlags, systemPackageConfig,
         pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T,
         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,
+        pgm_lcc, pgm_i,
+        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_i,
         opt_P_signature,
         opt_windres, opt_lo, opt_lc, opt_lcc,
 
@@ -146,6 +148,7 @@
 #include "GHCConstantsHaskellExports.hs"
         bLOCK_SIZE_W,
         wORD_SIZE_IN_BITS,
+        wordAlignment,
         tAG_MASK,
         mAX_PTR_TAG,
         tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD,
@@ -204,7 +207,7 @@
 import MonadUtils
 import qualified Pretty
 import SrcLoc
-import BasicTypes       ( IntWithInf, treatZeroAsInf )
+import BasicTypes       ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )
 import FastString
 import Fingerprint
 import Outputable
@@ -382,6 +385,7 @@
    | Opt_D_dump_spec
    | Opt_D_dump_prep
    | Opt_D_dump_stg
+   | Opt_D_dump_stg_final
    | Opt_D_dump_call_arity
    | Opt_D_dump_exitify
    | Opt_D_dump_stranal
@@ -1340,6 +1344,7 @@
                                          -- See Note [Repeated -optP hashing]
   sOpt_F                 :: [String],
   sOpt_c                 :: [String],
+  sOpt_cxx               :: [String],
   sOpt_a                 :: [String],
   sOpt_l                 :: [String],
   sOpt_windres           :: [String],
@@ -1423,6 +1428,8 @@
 opt_c                 :: DynFlags -> [String]
 opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)
             ++ sOpt_c (settings dflags)
+opt_cxx               :: DynFlags -> [String]
+opt_cxx dflags = sOpt_cxx (settings dflags)
 opt_a                 :: DynFlags -> [String]
 opt_a dflags = sOpt_a (settings dflags)
 opt_l                 :: DynFlags -> [String]
@@ -1817,6 +1824,12 @@
           dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo
       in dflags4
 
+-- | Compute the path of the dynamic object corresponding to an object file.
+dynamicOutputFile :: DynFlags -> FilePath -> FilePath
+dynamicOutputFile dflags outputFile = dynOut outputFile
+  where
+    dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension
+
 -----------------------------------------------------------------------------
 
 -- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value
@@ -2520,7 +2533,7 @@
          setDynObjectSuf, setDynHiSuf,
          setDylibInstallName,
          setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,
-         setPgmP, addOptl, addOptc, addOptP,
+         setPgmP, addOptl, addOptc, addOptcxx, addOptP,
          addCmdlineFramework, addHaddockOpts, addGhciScript,
          setInteractivePrint
    :: String -> DynFlags -> DynFlags
@@ -2636,6 +2649,7 @@
 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})
+addOptcxx f = alterSettings (\s -> s { sOpt_cxx = f : sOpt_cxx s})
 addOptP   f = alterSettings (\s -> s { sOpt_P   = f : sOpt_P s
                                      , sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s)
                                      })
@@ -2765,11 +2779,11 @@
   let chooseOutput
         | isJust (outputFile dflags3)          -- Only iff user specified -o ...
         , not (isJust (dynOutputFile dflags3)) -- but not -dyno
-        = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) }
+        = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile }
         | otherwise
         = return dflags3
         where
-          dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension
+          outFile = fromJust $ outputFile dflags3
   dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3)
 
   let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4
@@ -3038,6 +3052,8 @@
       (hasArg (\f -> alterSettings (\s -> s { sOpt_F   = f : sOpt_F s})))
   , make_ord_flag defFlag "optc"
       (hasArg addOptc)
+  , make_ord_flag defFlag "optcxx"
+      (hasArg addOptcxx)
   , make_ord_flag defFlag "opta"
       (hasArg (\f -> alterSettings (\s -> s { sOpt_a   = f : sOpt_a s})))
   , make_ord_flag defFlag "optl"
@@ -3331,6 +3347,8 @@
         (setDumpFlag Opt_D_dump_prep)
   , make_ord_flag defGhcFlag "ddump-stg"
         (setDumpFlag Opt_D_dump_stg)
+  , make_ord_flag defGhcFlag "ddump-stg-final"
+        (setDumpFlag Opt_D_dump_stg_final)
   , make_ord_flag defGhcFlag "ddump-call-arity"
         (setDumpFlag Opt_D_dump_call_arity)
   , make_ord_flag defGhcFlag "ddump-exitify"
@@ -5654,6 +5672,9 @@
 wORD_SIZE_IN_BITS :: DynFlags -> Int
 wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8
 
+wordAlignment :: DynFlags -> Alignment
+wordAlignment dflags = alignmentOf (wORD_SIZE dflags)
+
 tAG_MASK :: DynFlags -> Int
 tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1
 
@@ -5822,19 +5843,23 @@
 isSseEnabled :: DynFlags -> Bool
 isSseEnabled dflags = case platformArch (targetPlatform dflags) of
     ArchX86_64 -> True
-    ArchX86    -> sseVersion dflags >= Just SSE1
+    ArchX86    -> True
     _          -> False
 
 isSse2Enabled :: DynFlags -> Bool
 isSse2Enabled dflags = case platformArch (targetPlatform dflags) of
-    ArchX86_64 -> -- SSE2 is fixed on for x86_64.  It would be
-                  -- possible to make it optional, but we'd need to
-                  -- fix at least the foreign call code where the
-                  -- calling convention specifies the use of xmm regs,
-                  -- and possibly other places.
-                  True
-    ArchX86    -> sseVersion dflags >= Just SSE2
+  -- We Assume  SSE1 and SSE2 operations are available on both
+  -- x86 and x86_64. Historically we didn't default to SSE2 and
+  -- SSE1 on x86, which results in defacto nondeterminism for how
+  -- rounding behaves in the associated x87 floating point instructions
+  -- because variations in the spill/fpu stack placement of arguments for
+  -- operations would change the precision and final result of what
+  -- would otherwise be the same expressions with respect to single or
+  -- double precision IEEE floating point computations.
+    ArchX86_64 -> True
+    ArchX86    -> True
     _          -> False
+
 
 isSse4_2Enabled :: DynFlags -> Bool
 isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -30,6 +30,7 @@
         ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
         ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),
         ForeignSrcLang(..),
+        phaseForeignLanguage,
 
         ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
         msHsFilePath, msHiFilePath, msObjFilePath,
@@ -182,6 +183,7 @@
 import DynFlags
 import DriverPhases     ( Phase, HscSource(..), hscSourceString
                         , isHsBootOrSig, isHsigFile )
+import qualified DriverPhases as Phase
 import BasicTypes
 import IfaceSyn
 import Maybes
@@ -2803,6 +2805,9 @@
 msHiFilePath  ms = ml_hi_file  (ms_location ms)
 msObjFilePath ms = ml_obj_file (ms_location ms)
 
+msDynObjFilePath :: ModSummary -> DynFlags -> FilePath
+msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)
+
 -- | Did this 'ModSummary' originate from a hs-boot file?
 isBootSummary :: ModSummary -> Bool
 isBootSummary ms = ms_hsc_src ms == HsBootFile
@@ -2822,20 +2827,26 @@
 showModMsg dflags target recomp mod_summary = showSDoc dflags $
    if gopt Opt_HideSourcePaths dflags
       then text mod_str
-      else hsep
+      else hsep $
          [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')
          , char '('
          , text (op $ msHsFilePath mod_summary) <> char ','
-         , case target of
-              HscInterpreted | recomp -> text "interpreted"
-              HscNothing              -> text "nothing"
-              _                       -> text (op $ msObjFilePath mod_summary)
-         , char ')'
-         ]
+         ] ++
+         if gopt Opt_BuildDynamicToo dflags
+            then [ text obj_file <> char ','
+                 , text dyn_file
+                 , char ')'
+                 ]
+            else [ text obj_file, char ')' ]
   where
-    op      = normalise
-    mod     = moduleName (ms_mod mod_summary)
-    mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
+    op       = normalise
+    mod      = moduleName (ms_mod mod_summary)
+    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
+    dyn_file = op $ msDynObjFilePath mod_summary dflags
+    obj_file = case target of
+                HscInterpreted | recomp -> "interpreted"
+                HscNothing              -> "nothing"
+                _                       -> (op $ msObjFilePath mod_summary)
 
 {-
 ************************************************************************
@@ -3136,3 +3147,15 @@
 explanation for how GHC ensures that all the conlikes in a COMPLETE set are
 consistent.
 -}
+
+-- | Foreign language of the phase if the phase deals with a foreign code
+phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang
+phaseForeignLanguage phase = case phase of
+  Phase.Cc           -> Just LangC
+  Phase.Ccxx         -> Just LangCxx
+  Phase.Cobjc        -> Just LangObjc
+  Phase.Cobjcxx      -> Just LangObjcxx
+  Phase.HCc          -> Just LangC
+  Phase.As _         -> Just LangAsm
+  Phase.MergeForeign -> Just RawObject
+  _                  -> Nothing
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -50,7 +50,6 @@
 
         -- Bunch of functions in the parser monad for
         -- checking and constructing values
-        checkBlockArguments,
         checkPrecP,           -- Int -> P Int
         checkContext,         -- HsType -> P HsContext
         checkPattern,         -- HsExp -> P HsPat
@@ -61,7 +60,6 @@
         checkMonadComp,       -- P (HsStmtContext RdrName)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
-        checkDoAndIfThenElse,
         LRuleTyTmVar, RuleTyTmVar(..),
         mkRuleBndrs, mkRuleTyVarBndrs,
         checkRuleTyVarBndrNames,
@@ -94,14 +92,6 @@
         ExpCmdI(..),
         ecFromExp,
         ecFromCmd,
-        ecHsLam,
-        ecHsLet,
-        ecOpApp,
-        ecHsCase,
-        ecHsApp,
-        ecHsIf,
-        ecHsDo,
-        ecHsPar,
 
     ) where
 
@@ -672,10 +662,8 @@
                , con_forall = noLoc $ isJust mb_forall
                , con_ex_tvs = mb_forall `orElse` []
                , con_mb_cxt = mb_cxt
-               , con_args   = args'
+               , con_args   = args
                , con_doc    = Nothing }
-  where
-    args' = nudgeHsSrcBangs args
 
 mkGadtDecl :: [Located RdrName]
            -> LHsType GhcPs     -- Always a HsForAllTy
@@ -686,7 +674,7 @@
                  , con_forall = cL l $ isLHsForAllTy ty'
                  , con_qvars  = mkHsQTvs tvs
                  , con_mb_cxt = mcxt
-                 , con_args   = args'
+                 , con_args   = args
                  , con_res_ty = res_ty
                  , con_doc    = Nothing }
     , anns1 ++ anns2)
@@ -703,7 +691,6 @@
       = (Nothing, tau, ann)
 
     (args, res_ty) = split_tau tau
-    args' = nudgeHsSrcBangs args
 
     -- See Note [GADT abstract syntax] in HsDecls
     split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty))
@@ -715,28 +702,7 @@
                                                        (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 (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) =
-      cL 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.
 -- When parsing:
@@ -1004,8 +970,9 @@
 
 -- | Yield a parse error if we have a function applied directly to a do block
 -- etc. and BlockArguments is not enabled.
-checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV ()
-checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd }
+checkExpBlockArguments :: LHsExpr GhcPs -> P ()
+checkCmdBlockArguments :: LHsCmd GhcPs -> P ()
+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)
   where
     checkExpr :: LHsExpr GhcPs -> P ()
     checkExpr expr = case unLoc expr of
@@ -1315,19 +1282,6 @@
     default_RDR = mkUnqual varName (fsLit "default")
     pattern_RDR = mkUnqual varName (fsLit "pattern")
 
-checkDoAndIfThenElse
-  :: forall b. ExpCmdI b =>
-     LHsExpr GhcPs
-  -> Bool
-  -> Located (b GhcPs)
-  -> Bool
-  -> Located (b GhcPs)
-  -> P ()
-checkDoAndIfThenElse =
-  case expCmdG @b of
-    ExpG -> checkDoAndIfThenElse'
-    CmdG -> checkDoAndIfThenElse'
-
 checkDoAndIfThenElse'
   :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
   => a -> Bool -> b -> Bool -> c -> P ()
@@ -1924,73 +1878,78 @@
 newtype ExpCmdP =
   ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
 
--- See Note [Ambiguous syntactic categories]
-data ExpCmdG b where
-  ExpG :: ExpCmdG HsExpr
-  CmdG :: ExpCmdG HsCmd
-
--- See Note [Ambiguous syntactic categories]
-class    ExpCmdI b      where expCmdG :: ExpCmdG b
-instance ExpCmdI HsExpr where expCmdG = ExpG
-instance ExpCmdI HsCmd  where expCmdG = CmdG
-
-ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
-ecFromCmd c@(getLoc -> l) = ExpCmdP onB
-  where
-    onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
-    onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c }
-    onExp :: P (LHsExpr GhcPs)
-    onExp = do
-      addError l $ vcat
-        [ text "Arrow command found where an expression was expected:",
-          nest 2 (ppr c) ]
-      return (cL l hsHoleExpr)
-
 ecFromExp :: LHsExpr GhcPs -> ExpCmdP
-ecFromExp e@(getLoc -> l) = ExpCmdP onB
-  where
-    onB :: forall b. ExpCmdI b => PV (Located (b GhcPs))
-    onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd }
-    onCmd :: P (LHsCmd GhcPs)
-    onCmd =
-      addFatalError l $
-        text "Parse error in command:" <+> ppr e
-
-hsHoleExpr :: HsExpr (GhcPass id)
-hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
+ecFromExp a = ExpCmdP (ecFromExp' a)
 
-ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt }
+ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
+ecFromCmd a = ExpCmdP (ecFromCmd' a)
 
-ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
-ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt }
+-- See Note [Ambiguous syntactic categories]
+class ExpCmdI b where
+  -- | Return a command without ambiguity, or fail in a non-command context.
+  ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))
+  -- | Return an expression without ambiguity, or fail in a non-expression context.
+  ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))
+  -- | Disambiguate "\... -> ..." (lambda)
+  ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+  -- | Disambiguate "let ... in ..."
+  ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
+  -- | Disambiguate "f # x" (infix operator)
+  ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs
+  -- | Disambiguate "case ... of ..."
+  ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
+  -- | Disambiguate "f x" (function application)
+  ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
+  -- | Disambiguate "if ... then ... else ..."
+  ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
+  -- | Disambiguate "do { ... }" (do notation)
+  ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
+  -- | Disambiguate "( ... )" (parentheses)
+  ecHsPar :: Located (b GhcPs) -> b GhcPs
+  -- | Check if the argument requires -XBlockArguments.
+  checkBlockArguments :: Located (b GhcPs) -> PV ()
+  -- | Check if -XDoAndIfThenElse is enabled.
+  checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
+                                        -> Bool -> Located (b GhcPs) -> P ()
 
-ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs
-        -> Located (b GhcPs) -> b GhcPs
-ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp }
-  where
-    cmdOpApp c1 op c2 =
+instance ExpCmdI HsCmd where
+  ecFromCmd' = return
+  ecFromExp' (dL-> L l e) =
+    addFatalError l $
+      text "Parse error in command:" <+> ppr e
+  ecHsLam = HsCmdLam noExt
+  ecHsLet = HsCmdLet noExt
+  ecOpApp c1 op c2 =
       let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
       HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
-
-ecHsCase :: forall b. ExpCmdI b =>
-  LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
-ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt }
-
-ecHsApp :: forall b. ExpCmdI b =>
-  Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
-ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt }
-
-ecHsIf :: forall b. ExpCmdI b =>
-   LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
-ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf }
+  ecHsCase = HsCmdCase noExt
+  ecHsApp = HsCmdApp noExt
+  ecHsIf = mkHsCmdIf
+  ecHsDo = HsCmdDo noExt
+  ecHsPar = HsCmdPar noExt
+  checkBlockArguments = checkCmdBlockArguments
+  checkDoAndIfThenElse = checkDoAndIfThenElse'
 
-ecHsDo :: forall b. ExpCmdI b =>
-  Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
-ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt }
+instance ExpCmdI HsExpr where
+  ecFromCmd' (dL -> L l c) = do
+    addError l $ vcat
+      [ text "Arrow command found where an expression was expected:",
+        nest 2 (ppr c) ]
+    return (cL l hsHoleExpr)
+  ecFromExp' = return
+  ecHsLam = HsLam noExt
+  ecHsLet = HsLet noExt
+  ecOpApp = OpApp noExt
+  ecHsCase = HsCase noExt
+  ecHsApp = HsApp noExt
+  ecHsIf = mkHsIf
+  ecHsDo = HsDo noExt DoExpr
+  ecHsPar = HsPar noExt
+  checkBlockArguments = checkExpBlockArguments
+  checkDoAndIfThenElse = checkDoAndIfThenElse'
 
-ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs
-ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt }
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
 
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2043,19 +2002,12 @@
 
 The solution that keeps basic definitions (such as HsExpr) clean, keeps the
 concerns local to the parser, and does not require duplication of hsSyn types,
-or an extra pass over the entire AST, is to parse into a function from a GADT
-to a parser-validator:
-
-    data ExpCmdG b where
-      ExpG :: ExpCmdG HsExpr
-      CmdG :: ExpCmdG HsCmd
-
-    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+or an extra pass over the entire AST, is to parse into an overloaded
+parser-validator (a so-called tagless final encoding):
 
-    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
-    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
-    checkExp f = f ExpG  -- interpret as an expression
-    checkCmd f = f CmdG  -- interpret as a command
+    class ExpCmdI b where ...
+    instance ExpCmdI HsCmd where ...
+    instance ExpCmdI HsExp where ...
 
 Consider the 'alts' production used to parse case-of alternatives:
 
@@ -2065,30 +2017,6 @@
 
 We abstract over LHsExpr, and it becomes:
 
-  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
-    : alts1
-        { \tag -> $1 tag >>= \ $1 ->
-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
-    | ';' alts
-        { \tag -> $2 tag >>= \ $2 ->
-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
-
-Note that 'ExpCmdG' is a singleton type, the value is completely
-determined by the type:
-
-  when (b~HsExpr),  tag = ExpG
-  when (b~HsCmd),   tag = CmdG
-
-This is a clear indication that we can use a class to pass this value behind
-the scenes:
-
-  class    ExpCmdI b      where expCmdG :: ExpCmdG b
-  instance ExpCmdI HsExpr where expCmdG = ExpG
-  instance ExpCmdI HsCmd  where expCmdG = CmdG
-
-And now the 'alts' production is simplified, as we no longer need to
-thread 'tag' explicitly:
-
   alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
     : alts1     { $1 >>= \ $1 ->
                   return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
@@ -2330,6 +2258,63 @@
 
 And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',
 'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!
+
+Alternative VIII, a function from a GADT
+----------------------------------------
+We could avoid code duplication of the Alternative VII by representing the product
+as a function from a GADT:
+
+    data ExpCmdG b where
+      ExpG :: ExpCmdG HsExpr
+      CmdG :: ExpCmdG HsCmd
+
+    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))
+
+    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)
+    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)
+    checkExp f = f ExpG  -- interpret as an expression
+    checkCmd f = f CmdG  -- interpret as a command
+
+Consider the 'alts' production used to parse case-of alternatives:
+
+  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }
+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+We abstract over LHsExpr, and it becomes:
+
+  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+    : alts1
+        { \tag -> $1 tag >>= \ $1 ->
+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+    | ';' alts
+        { \tag -> $2 tag >>= \ $2 ->
+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+Note that 'ExpCmdG' is a singleton type, the value is completely
+determined by the type:
+
+  when (b~HsExpr),  tag = ExpG
+  when (b~HsCmd),   tag = CmdG
+
+This is a clear indication that we can use a class to pass this value behind
+the scenes:
+
+  class    ExpCmdI b      where expCmdG :: ExpCmdG b
+  instance ExpCmdI HsExpr where expCmdG = ExpG
+  instance ExpCmdI HsCmd  where expCmdG = CmdG
+
+And now the 'alts' production is simplified, as we no longer need to
+thread 'tag' explicitly:
+
+  alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
+    : alts1     { $1 >>= \ $1 ->
+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
+    | ';' alts  { $2 >>= \ $2 ->
+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
+
+This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to
+more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.
 
 -}
 
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -778,8 +778,8 @@
 ************************************************************************
 -}
 
-msg :: Severity -> SDoc -> CoreM ()
-msg sev doc
+msg :: Severity -> WarnReason -> SDoc -> CoreM ()
+msg sev reason doc
   = do { dflags <- getDynFlags
        ; loc    <- getSrcSpanM
        ; unqual <- getPrintUnqualified
@@ -791,7 +791,7 @@
              err_sty  = mkErrStyle dflags unqual
              user_sty = mkUserStyle dflags unqual AllTheWay
              dump_sty = mkDumpStyle dflags unqual
-       ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -799,7 +799,7 @@
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg SevInfo
+putMsg = msg SevInfo NoReason
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsgS :: String -> CoreM ()
@@ -807,9 +807,9 @@
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg SevError
+errorMsg = msg SevError NoReason
 
-warnMsg :: SDoc -> CoreM ()
+warnMsg :: WarnReason -> SDoc -> CoreM ()
 warnMsg = msg SevWarning
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
@@ -818,7 +818,7 @@
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg SevFatal
+fatalErrorMsg = msg SevFatal NoReason
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -826,7 +826,7 @@
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg SevDump
+debugTraceMsg = msg SevDump NoReason
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs
--- a/compiler/types/OptCoercion.hs
+++ b/compiler/types/OptCoercion.hs
@@ -118,8 +118,8 @@
         (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co
         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
     in
-    ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
-             substTy env in_ty2 `eqType` out_ty2 &&
+    ASSERT2( substTyUnchecked env in_ty1 `eqType` out_ty1 &&
+             substTyUnchecked env in_ty2 `eqType` out_ty2 &&
              in_role == out_role
            , text "optCoercion changed types!"
              $$ hang (text "in_co:") 2 (ppr co)
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -1328,12 +1328,12 @@
    number of bits.  It may represent a signed or unsigned integer, a
    floating-point value, or an address.
 
-    data Width = W8 | W16 | W32 | W64 | W80 | W128
+    data Width = W8 | W16 | W32 | W64  | W128
 
  - Size, which is used in the native code generator, is Width +
    floating point information.
 
-   data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80
+   data Size = II8 | II16 | II32 | II64 | FF32 | FF64
 
    it is necessary because e.g. the instruction to move a 64-bit float
    on x86 (movsd) is different from the instruction to move a 64-bit
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -1044,7 +1044,7 @@
     init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))
 
     go :: TCvSubst -> Type -> [Type] -> Type
-    go subst ty [] = substTy subst ty
+    go subst ty [] = substTyUnchecked subst ty
 
     go subst ty all_args@(arg:args)
       | Just ty' <- coreView ty
@@ -1698,6 +1698,21 @@
         subst' = extendTvSubst subst tv arg_ty
     go subst (TyVarTy tv) arg_tys
       | Just ki <- lookupTyVar subst tv = go subst ki arg_tys
+    -- This FunTy case is important to handle kinds with nested foralls, such
+    -- as this kind (inspired by #16518):
+    --
+    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type
+    --
+    -- Here, we want to get the following ArgFlags:
+    --
+    -- [Inferred,   Specified, Required, Required, Specified, Required]
+    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type
+    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)
+      = argf : go subst res_ki arg_tys
+      where
+        argf = case af of
+                 VisArg   -> Required
+                 InvisArg -> Inferred
     go _ _ arg_tys = map (const Required) arg_tys
                         -- something is ill-kinded. But this can happen
                         -- when printing errors. Assume everything is Required.
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -327,6 +327,10 @@
 instance IsString SDoc where
   fromString = text
 
+-- The lazy programmer's friend.
+instance Outputable SDoc where
+  ppr = id
+
 initSDocContext :: DynFlags -> PprStyle -> SDocContext
 initSDocContext dflags sty = SDC
   { sdocStyle = sty
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -1149,7 +1149,6 @@
     pow2 x | x == 1 = 0
            | otherwise = 1 + pow2 (x `shiftR` 1)
 
-
 {-
 -- -----------------------------------------------------------------------------
 -- Floats
diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal
--- a/ghc-lib-parser.cabal
+++ b/ghc-lib-parser.cabal
@@ -1,7 +1,7 @@
 cabal-version: >=1.22
 build-type: Simple
 name: ghc-lib-parser
-version: 0.20190402
+version: 0.20190423
 license: BSD3
 license-file: LICENSE
 category: Development
@@ -55,7 +55,7 @@
 tested-with:GHC==8.6.3
 source-repository head
     type: git
-    location: git://git.haskell.org/ghc.git
+    location: git@github.com:digital-asset/ghc-lib.git
 
 library
     default-language:   Haskell2010
@@ -124,7 +124,6 @@
         UndecidableInstances
     c-sources:
         compiler/cbits/genSym.c
-        compiler/ghci/keepCAFsForGHCi.c
         compiler/parser/cutils.c
     hs-source-dirs:
         compiler
diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h
--- a/ghc-lib/generated/ghcversion.h
+++ b/ghc-lib/generated/ghcversion.h
@@ -5,7 +5,8 @@
 # define __GLASGOW_HASKELL__ 809
 #endif
 
-#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20190402
+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190423
 
 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\
    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs
--- a/ghc-lib/stage0/compiler/build/Parser.hs
+++ b/ghc-lib/stage0/compiler/build/Parser.hs
@@ -9562,7 +9562,7 @@
 
 
 {-# LINE 18 "<built-in>" #-}
-{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc75776_0/ghc_2.h" #-}
+{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc27488_0/ghc_2.h" #-}
 
 
 
diff --git a/ghc-lib/stage1/compiler/build/Config.hs b/ghc-lib/stage1/compiler/build/Config.hs
--- a/ghc-lib/stage1/compiler/build/Config.hs
+++ b/ghc-lib/stage1/compiler/build/Config.hs
@@ -19,17 +19,17 @@
 cProjectName          :: String
 cProjectName          = "The Glorious Glasgow Haskell Compilation System"
 cProjectGitCommitId   :: String
-cProjectGitCommitId   = "bf73419518ca550e85188616f860961c7e2a336b"
+cProjectGitCommitId   = "ab9b3ace24e57359d5745dd9abf593d1ec94a0ad"
 cProjectVersion       :: String
-cProjectVersion       = "8.9.20190402"
+cProjectVersion       = "8.9.0.20190423"
 cProjectVersionInt    :: String
 cProjectVersionInt    = "809"
 cProjectPatchLevel    :: String
-cProjectPatchLevel    = "20190402"
+cProjectPatchLevel    = "020190423"
 cProjectPatchLevel1   :: String
-cProjectPatchLevel1   = "20190402"
+cProjectPatchLevel1   = "0"
 cProjectPatchLevel2   :: String
-cProjectPatchLevel2   = ""
+cProjectPatchLevel2   = "20190423"
 cBooterVersion        :: String
 cBooterVersion        = "8.6.4"
 cStage                :: String
diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings
--- a/ghc-lib/stage1/lib/settings
+++ b/ghc-lib/stage1/lib/settings
@@ -1,35 +1,34 @@
-[("GCC extra via C opts", " -fwrapv -fno-builtin"),
- ("C compiler command", "gcc"),
- ("C compiler flags", ""),
- ("C compiler link flags", " "),
- ("C compiler supports -no-pie", "NO"),
- ("Haskell CPP command","gcc"),
- ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),
- ("ld command", "ld"),
- ("ld flags", ""),
- ("ld supports compact unwind", "YES"),
- ("ld supports build-id", "NO"),
- ("ld supports filelist", "YES"),
- ("ld is GNU ld", "NO"),
- ("ar command", "ar"),
- ("ar flags", "qcls"),
- ("ar supports at file", "NO"),
- ("ranlib command", "ranlib"),
- ("touch command", "touch"),
- ("dllwrap command", "/bin/false"),
- ("windres command", "/bin/false"),
- ("libtool command", "libtool"),
- ("cross compiling", "NO"),
- ("target os", "OSDarwin"),
- ("target arch", "ArchX86_64"),
- ("target word size", "8"),
- ("target has GNU nonexec stack", "False"),
- ("target has .ident directive", "True"),
- ("target has subsections via symbols", "True"),
- ("target has RTS linker", "YES"),
- ("Unregisterised", "NO"),
- ("LLVM llc command", "llc"),
- ("LLVM opt command", "opt"),
- ("LLVM clang command", "clang")
- ]
-
+[("GCC extra via C opts", " -fwrapv -fno-builtin")
+,("C compiler command", "gcc")
+,("C compiler flags", "")
+,("C compiler link flags", " ")
+,("C compiler supports -no-pie", "NO")
+,("Haskell CPP command", "gcc")
+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")
+,("ld command", "ld")
+,("ld flags", "")
+,("ld supports compact unwind", "YES")
+,("ld supports build-id", "NO")
+,("ld supports filelist", "YES")
+,("ld is GNU ld", "NO")
+,("ar command", "ar")
+,("ar flags", "qcls")
+,("ar supports at file", "NO")
+,("ranlib command", "ranlib")
+,("touch command", "touch")
+,("dllwrap command", "/bin/false")
+,("windres command", "/bin/false")
+,("libtool command", "libtool")
+,("cross compiling", "NO")
+,("target os", "OSDarwin")
+,("target arch", "ArchX86_64")
+,("target word size", "8")
+,("target has GNU nonexec stack", "False")
+,("target has .ident directive", "True")
+,("target has subsections via symbols", "True")
+,("target has RTS linker", "YES")
+,("Unregisterised", "NO")
+,("LLVM llc command", "llc")
+,("LLVM opt command", "opt")
+,("LLVM clang command", "clang")
+]
diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs
--- a/includes/CodeGen.Platform.hs
+++ b/includes/CodeGen.Platform.hs
@@ -41,65 +41,59 @@
 #  define r15   15
 # endif
 
-# define fake0 16
-# define fake1 17
-# define fake2 18
-# define fake3 19
-# define fake4 20
-# define fake5 21
 
 -- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence
 -- being assigned the same RegNos.
-# define xmm0  24
-# define xmm1  25
-# define xmm2  26
-# define xmm3  27
-# define xmm4  28
-# define xmm5  29
-# define xmm6  30
-# define xmm7  31
-# define xmm8  32
-# define xmm9  33
-# define xmm10 34
-# define xmm11 35
-# define xmm12 36
-# define xmm13 37
-# define xmm14 38
-# define xmm15 39
+# define xmm0  16
+# define xmm1  17
+# define xmm2  18
+# define xmm3  19
+# define xmm4  20
+# define xmm5  21
+# define xmm6  22
+# define xmm7  23
+# define xmm8  24
+# define xmm9  25
+# define xmm10 26
+# define xmm11 27
+# define xmm12 28
+# define xmm13 29
+# define xmm14 30
+# define xmm15 31
 
-# define ymm0  24
-# define ymm1  25
-# define ymm2  26
-# define ymm3  27
-# define ymm4  28
-# define ymm5  29
-# define ymm6  30
-# define ymm7  31
-# define ymm8  32
-# define ymm9  33
-# define ymm10 34
-# define ymm11 35
-# define ymm12 36
-# define ymm13 37
-# define ymm14 38
-# define ymm15 39
+# define ymm0  16
+# define ymm1  17
+# define ymm2  18
+# define ymm3  19
+# define ymm4  20
+# define ymm5  21
+# define ymm6  22
+# define ymm7  23
+# define ymm8  24
+# define ymm9  25
+# define ymm10 26
+# define ymm11 27
+# define ymm12 28
+# define ymm13 29
+# define ymm14 30
+# define ymm15 31
 
-# define zmm0  24
-# define zmm1  25
-# define zmm2  26
-# define zmm3  27
-# define zmm4  28
-# define zmm5  29
-# define zmm6  30
-# define zmm7  31
-# define zmm8  32
-# define zmm9  33
-# define zmm10 34
-# define zmm11 35
-# define zmm12 36
-# define zmm13 37
-# define zmm14 38
-# define zmm15 39
+# define zmm0  16
+# define zmm1  17
+# define zmm2  18
+# define zmm3  19
+# define zmm4  20
+# define zmm5  21
+# define zmm6  22
+# define zmm7  23
+# define zmm8  24
+# define zmm9  25
+# define zmm10 26
+# define zmm11 27
+# define zmm12 28
+# define zmm13 29
+# define zmm14 30
+# define zmm15 31
 
 -- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.
 -- Since it's only used to check 'isJust', the actual values don't matter, thus
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE CPP, DeriveDataTypeable,
              DeriveGeneric, FlexibleInstances, DefaultSignatures,
              RankNTypes, RoleAnnotations, ScopedTypeVariables,
+             MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
+             GADTs, UnboxedTuples, UnboxedSums, TypeInType,
              Trustworthy #-}
 
 {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
@@ -32,13 +34,17 @@
 import Control.Monad (liftM)
 import Control.Monad.IO.Class (MonadIO (..))
 import System.IO        ( hPutStrLn, stderr )
-import Data.Char        ( isAlpha, isAlphaNum, isUpper )
+import Data.Char        ( isAlpha, isAlphaNum, isUpper, ord )
 import Data.Int
 import Data.List.NonEmpty ( NonEmpty(..) )
 import Data.Void        ( Void, absurd )
 import Data.Word
 import Data.Ratio
+import GHC.CString      ( unpackCString# )
 import GHC.Generics     ( Generic )
+import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),
+                          TYPE, RuntimeRep(..) )
+import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# )
 import GHC.Lexeme       ( startsVarSym, startsVarId )
 import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
@@ -201,7 +207,7 @@
 -----------------------------------------------------
 
 type role TExp nominal   -- See Note [Role of TExp]
-newtype TExp a = TExp
+newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp
   { unType :: Exp -- ^ Underlying untyped Template Haskell expression
   }
 -- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed
@@ -240,7 +246,9 @@
 
 -- | Discard the type annotation and produce a plain Template Haskell
 -- expression
-unTypeQ :: Q (TExp a) -> Q Exp
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp
 unTypeQ m = do { TExp e <- m
                ; return e }
 
@@ -248,7 +256,9 @@
 --
 -- This is unsafe because GHC cannot check for you that the expression
 -- really does have the type you claim it has.
-unsafeTExpCoerce :: Q Exp -> Q (TExp a)
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a)
 unsafeTExpCoerce m = do { e <- m
                         ; return (TExp e) }
 
@@ -651,17 +661,18 @@
 
 -- | A 'Lift' instance can have any of its values turned into a Template
 -- Haskell expression. This is needed when a value used within a Template
--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not
--- at the top level. As an example:
+-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
+-- @[|| ... ||]@) but not at the top level. As an example:
 --
--- > add1 :: Int -> Q Exp
--- > add1 x = [| x + 1 |]
+-- > add1 :: Int -> Q (TExp Int)
+-- > add1 x = [|| x + 1 ||]
 --
 -- Template Haskell has no way of knowing what value @x@ will take on at
 -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
 --
--- A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@
--- is a Template Haskell splice.
+-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
+-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
+-- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@.
 --
 -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
 -- GHC language extension:
@@ -673,10 +684,13 @@
 -- >
 -- > data Bar a = Bar1 a (Bar a) | Bar2 String
 -- >   deriving Lift
-class Lift t where
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+class Lift (t :: TYPE r) where
   -- | Turn a value into a Template Haskell expression, suitable for use in
   -- a splice.
   lift :: t -> Q Exp
+  default lift :: (r ~ 'LiftedRep) => t -> Q Exp
   lift = unTypeQ . liftTyped
 
   -- | Turn a value into a Template Haskell typed expression, suitable for use
@@ -684,73 +698,127 @@
   --
   -- @since 2.16.0.0
   liftTyped :: t -> Q (TExp t)
-  liftTyped = unsafeTExpCoerce . lift
 
-  {-# MINIMAL lift | liftTyped #-}
 
-
 -- If you add any instances here, consider updating test th/TH_Lift
 instance Lift Integer where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL x))
 
 instance Lift Int where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
+-- | @since 2.16.0.0
+instance Lift Int# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
+
 instance Lift Int8 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int16 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int32 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int64 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
+-- | @since 2.16.0.0
+instance Lift Word# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
+
 instance Lift Word where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word8 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word16 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word32 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word64 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Natural where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Integral a => Lift (Ratio a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
 instance Lift Float where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
+-- | @since 2.16.0.0
+instance Lift Float# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (FloatPrimL (toRational (F# x))))
+
 instance Lift Double where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
+-- | @since 2.16.0.0
+instance Lift Double# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (DoublePrimL (toRational (D# x))))
+
 instance Lift Char where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (CharL x))
 
+-- | @since 2.16.0.0
+instance Lift Char# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (CharPrimL (C# x)))
+
 instance Lift Bool where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift True  = return (ConE trueName)
   lift False = return (ConE falseName)
 
+-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
+-- the given memory address.
+--
+-- @since 2.16.0.0
+instance Lift Addr# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
+
 instance Lift a => Lift (Maybe a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift Nothing  = return (ConE nothingName)
   lift (Just x) = liftM (ConE justName `AppE`) (lift x)
 
 instance (Lift a, Lift b) => Lift (Either a b) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)
   lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
 
 instance Lift a => Lift [a] where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
 
 liftString :: String -> Q Exp
@@ -759,6 +827,8 @@
 
 -- | @since 2.15.0.0
 instance Lift a => Lift (NonEmpty a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift (x :| xs) = do
     x' <- lift x
     xs' <- lift xs
@@ -766,38 +836,166 @@
 
 -- | @since 2.15.0.0
 instance Lift Void where
+  liftTyped = pure . absurd
   lift = pure . absurd
 
 instance Lift () where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift () = return (ConE (tupleDataName 0))
 
 instance (Lift a, Lift b) => Lift (a, b) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b)
     = liftM TupE $ sequence [lift a, lift b]
 
 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c)
     = liftM TupE $ sequence [lift a, lift b, lift c]
 
 instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
       => Lift (a, b, c, d, e) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
       => Lift (a, b, c, d, e, f) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
       => Lift (a, b, c, d, e, f, g) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f, g)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
 
+-- | @since 2.16.0.0
+instance Lift (# #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# #) = return (ConE (unboxedTupleTypeName 0))
+
+-- | @since 2.16.0.0
+instance (Lift a) => Lift (# a #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a #)
+    = liftM UnboxedTupE $ sequence [lift a]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a, b #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+      => Lift (# a, b, c #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+      => Lift (# a, b, c, d #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+      => Lift (# a, b, c, d, e #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+      => Lift (# a, b, c, d, e, f #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e, f #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+      => Lift (# a, b, c, d, e, f, g #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e, f, g #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a | b #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
+        (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+      => Lift (# a | b | c #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
+        (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3
+        (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+      => Lift (# a | b | c | d #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
+        (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4
+        (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4
+        (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+      => Lift (# a | b | c | d | e #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
+        (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5
+        (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5
+        (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5
+        (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+      => Lift (# a | b | c | d | e | f #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
+        (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6
+        (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6
+        (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6
+        (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6
+        (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+      => Lift (# a | b | c | d | e | f | g #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
+        (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7
+        (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7
+        (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7
+        (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7
+        (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7
+        (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7
+
 -- TH has a special form for literal strings,
 -- which we should take advantage of.
 -- NB: the lhs of the rule has no args, so that
@@ -1619,8 +1817,8 @@
          | WordPrimL Integer
          | FloatPrimL Rational
          | DoublePrimL Rational
-         | StringPrimL [Word8]  -- ^ A primitive C-style string, type Addr#
-         | BytesPrimL Bytes     -- ^ Some raw bytes, type Addr#:
+         | StringPrimL [Word8]  -- ^ A primitive C-style string, type 'Addr#'
+         | BytesPrimL Bytes     -- ^ Some raw bytes, type 'Addr#':
          | CharPrimL Char
     deriving( Show, Eq, Ord, Data, Generic )