Directed coercionswip/amg/dcoercion

This patch introduces a slimmer version of coercions, directed coercions,
which store fewer types within them. This more compact representation
considerably speeds up programs which involve many type family
reductions, as the coercion size no longer grows quadratically in
the number of reduction steps.

-------------------------
Metric Decrease:
    LargeRecord
    T12227
    T12545
    T13386
    T3064
    T5030
    T8095
    T9872a
    T9872b
    T9872b_defer
    T9872c
    T9872d
Metric Increase:
    CoOpt_Singletons
    T18223
    T9872a
    T9872b
    T9872c
    T9872d
-------------------------

69 files changed, 4228 insertions, 1142 deletions

diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index 21d537112e..f9febf29c2 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -14,6 +14,7 @@
 module GHC.Core.Coercion (
         -- * Main data type
         Coercion, CoercionN, CoercionR, CoercionP,
+        DCoercion(..), DCoercionN,
         MCoercion(..), MCoercionN, MCoercionR,
         CoSel(..), FunSel(..),
         UnivCoProvenance, CoercionHole(..),
@@ -50,6 +51,26 @@ module GHC.Core.Coercion (
         mkKindCo,
         castCoercionKind, castCoercionKind1, castCoercionKind2,
 
+        mkReflDCo,
+        mkAppDCo,
+        mkAppDCos,
+        mkTyConAppDCo,
+        mkFunDCo,
+        mkForAllDCo,
+        mkHomoForAllDCos,
+        mkGReflLeftDCo,
+        mkGReflRightDCo,
+        mkCoherenceLeftDCo,
+        mkCoherenceRightDCo,
+        mkTransDCo, mkHydrateDCo,
+        followDCo, fullyHydrateDCo, hydrateOneLayerDCo,
+        expandDCo, expandAxiomInstDCo, expandOneStepDCo,
+        mkDehydrateCo,
+        mkCoVarDCo,
+        castDCoercionKind1, castDCoercionKind2,
+        mkUnivDCo, mkProofIrrelDCo,
+        mkSubDCo,
+
         mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
         mkNomPrimEqPred,
 
@@ -64,6 +85,7 @@ module GHC.Core.Coercion (
         splitFunCo_maybe,
         splitForAllCo_maybe,
         splitForAllCo_ty_maybe, splitForAllCo_co_maybe,
+        splitForAllDCo_ty_maybe, splitForAllDCo_co_maybe,
 
         tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,
         tyConRoleListX, tyConRoleListRepresentational, funRole,
@@ -77,13 +99,15 @@ module GHC.Core.Coercion (
         mkHomoForAllMCo, mkFunResMCo, mkPiMCos,
         isReflMCo, checkReflexiveMCo,
 
+        isReflDCo, isReflexiveDCo,
+
         -- ** Coercion variables
         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
 
         -- ** Free variables
         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,
         tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,
-        coercionSize, anyFreeVarsOfCo,
+        coercionSize, anyFreeVarsOfCo, anyFreeVarsOfDCo,
 
         -- ** Substitution
         CvSubstEnv, emptyCvSubstEnv,
@@ -97,8 +121,10 @@ module GHC.Core.Coercion (
         emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,
         liftCoSubstVarBndrUsing, isMappedByLC,
 
+        mkLiftingContext,
         mkSubstLiftingContext, zapLiftingContext,
-        substForAllCoBndrUsingLC, lcSubst, lcInScopeSet,
+        substForAllCoBndrUsingLC, substForAllDCoBndrUsingLC,
+        lcSubst, lcInScopeSet,
 
         LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,
         substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,
@@ -121,6 +147,9 @@ module GHC.Core.Coercion (
         -- * Other
         promoteCoercion, buildCoercion,
 
+        downgradeRole_maybe,
+        downgradeDCoToRepresentational,
+
         multToCo, mkRuntimeRepCo,
 
         hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy,
@@ -143,6 +172,8 @@ import GHC.Core.Type
 import GHC.Core.TyCon
 import GHC.Core.TyCon.RecWalk
 import GHC.Core.Coercion.Axiom
+import {-# SOURCE #-} GHC.Core.FamInstEnv ( chooseBranch )
+import {-# SOURCE #-} GHC.Core.Unify ( tcMatchTys )
 import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
@@ -160,6 +191,7 @@ import GHC.Types.Unique.FM
 import GHC.Data.List.Infinite (Infinite (..))
 import qualified GHC.Data.List.Infinite as Inf
 
+import GHC.Utils.Monad
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -167,6 +199,8 @@ import GHC.Utils.Panic.Plain
 
 import Control.Monad (foldM, zipWithM)
 import Data.Function ( on )
+import Data.Functor.Identity (Identity(..))
+import Data.List ( zipWith4 )
 import Data.Char( isDigit )
 import qualified Data.Monoid as Monoid
 
@@ -571,6 +605,18 @@ splitForAllCo_co_maybe (ForAllCo cv k_co co)
   | isCoVar cv = Just (cv, k_co, co)
 splitForAllCo_co_maybe _ = Nothing
 
+-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder
+splitForAllDCo_ty_maybe :: DCoercion -> Maybe (TyVar, DCoercion, DCoercion)
+splitForAllDCo_ty_maybe (ForAllDCo tv k_dco dco)
+  | isTyVar tv = Just (tv, k_dco, dco)
+splitForAllDCo_ty_maybe _ = Nothing
+
+-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder
+splitForAllDCo_co_maybe :: DCoercion -> Maybe (CoVar, DCoercion, DCoercion)
+splitForAllDCo_co_maybe (ForAllDCo cv k_dco dco)
+  | isCoVar cv = Just (cv, k_dco, dco)
+splitForAllDCo_co_maybe _ = Nothing
+
 -------------------------------------------------------
 -- and some coercion kind stuff
 
@@ -593,7 +639,7 @@ coVarKindsTypesRole cv
 
 coVarKind :: CoVar -> Type
 coVarKind cv
-  = assert (isCoVar cv )
+  = assert (isCoVar cv)
     varType cv
 
 coVarRole :: CoVar -> Role
@@ -663,6 +709,7 @@ isReflCoVar_maybe cv
 isGReflCo :: Coercion -> Bool
 isGReflCo (GRefl{}) = True
 isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl
+isGReflCo (HydrateDCo _ _ dco _) = isGReflDCo dco
 isGReflCo _         = False
 
 -- | Tests if this coercion is obviously reflexive. Guaranteed to work
@@ -671,6 +718,7 @@ isGReflCo _         = False
 isReflCo :: Coercion -> Bool
 isReflCo (Refl{}) = True
 isReflCo (GRefl _ _ mco) | isGReflMCo mco = True
+isReflCo (HydrateDCo _ _ dco _) = isReflDCo dco
 isReflCo _ = False
 
 -- | Returns the type coerced if this coercion is a generalized reflexive
@@ -678,6 +726,9 @@ isReflCo _ = False
 isGReflCo_maybe :: Coercion -> Maybe (Type, Role)
 isGReflCo_maybe (GRefl r ty _) = Just (ty, r)
 isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)
+isGReflCo_maybe (HydrateDCo r ty dco _)
+  | isGReflDCo dco
+  = Just (ty, r)
 isGReflCo_maybe _ = Nothing
 
 -- | Returns the type coerced if this coercion is reflexive. Guaranteed
@@ -686,6 +737,9 @@ isGReflCo_maybe _ = Nothing
 isReflCo_maybe :: Coercion -> Maybe (Type, Role)
 isReflCo_maybe (Refl ty) = Just (ty, Nominal)
 isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
+isReflCo_maybe (HydrateDCo r ty dco _)
+  | isReflDCo dco
+  = Just (ty, r)
 isReflCo_maybe _ = Nothing
 
 -- | Slowly checks if the coercion is reflexive. Don't call this in a loop,
@@ -696,15 +750,35 @@ 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 ty) = Just (ty, Nominal)
-isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)
 isReflexiveCo_maybe co
+  | Just res <- isReflCo_maybe co
+  = Just res
   | ty1 `eqType` ty2
   = Just (ty1, r)
   | otherwise
   = Nothing
   where (Pair ty1 ty2, r) = coercionKindRole co
 
+isReflDCo :: DCoercion -> Bool
+isReflDCo ReflDCo            = True
+isReflDCo (GReflRightDCo co) = isGReflCo co
+isReflDCo (GReflLeftDCo  co) = isGReflCo co
+isReflDCo (DehydrateCo co)   = isReflCo co
+isReflDCo _                  = False
+
+isGReflDCo :: DCoercion -> Bool
+isGReflDCo ReflDCo            = True
+isGReflDCo (GReflRightDCo {}) = True
+isGReflDCo (GReflLeftDCo {})  = True
+isGReflDCo (DehydrateCo co)   = isGReflCo co
+isGReflDCo _                  = False
+
+isReflexiveDCo :: Role -> Type -> DCoercion -> Type -> Bool
+isReflexiveDCo _r l_ty dco r_ty
+  | isReflDCo dco
+  = True
+  | otherwise
+  = l_ty `eqType` r_ty
 
 {-
 %************************************************************************
@@ -919,6 +993,493 @@ mkAppCos :: Coercion
          -> Coercion
 mkAppCos co1 cos = foldl' mkAppCo co1 cos
 
+mkReflDCo :: DCoercion
+mkReflDCo = ReflDCo
+
+mkTyConAppDCo :: [DCoercion] -> DCoercion
+mkTyConAppDCo cos
+  | all isReflDCo cos = mkReflDCo -- See Note [Refl invariant]
+  | otherwise         = TyConAppDCo cos
+
+mkSubDCo :: HasDebugCallStack
+         => Type      -- ^ LHS type
+         -> DCoercion
+         -> Type      -- ^ RHS type
+         -> DCoercion
+mkSubDCo l_ty dco r_ty = case dco of
+  ReflDCo          -> ReflDCo
+  GReflRightDCo co -> GReflRightDCo co
+  GReflLeftDCo  co -> GReflLeftDCo  co
+  TyConAppDCo dcos
+    | Just (tc, arg_l_tys) <- splitTyConApp_maybe l_ty
+    , Just (_ , arg_r_tys) <- splitTyConApp_maybe r_ty
+    -> TyConAppDCo (applyRoles_dco tc arg_l_tys dcos arg_r_tys)
+    -- SLD TODO: we might need to get rid of this case,
+    -- to avoid calling applyRoles, which calls mkHydrateDCo.
+  DehydrateCo co
+    -> DehydrateCo (mkSubCo co)
+  UnivDCo prov r
+    -> UnivDCo prov r
+  _ -> SubDCo dco
+
+-- | Like 'mkTyConAppDCo', but specialised to the function arrow.
+--
+-- Unlike for 'Coercion', for 'DCoercion' the function arrow does not
+-- have special treatment, so this is just a helper function around
+-- 'mkTyConAppDCo'.
+mkFunDCo :: FunTyFlag
+         -> DCoercionN -- ^ multiplicity
+         -> DCoercionN -- ^ argument representation
+         -> DCoercionN -- ^ result representation
+         -> DCoercion  -- ^ argument
+         -> DCoercion  -- ^ result
+         -> DCoercion
+mkFunDCo ftf w repco1 repco2 co1 co2 =
+  if isFUNArg ftf
+  then mkTyConAppDCo [w, repco1, repco2, co1, co2]
+  else mkTyConAppDCo [   repco1, repco2, co1, co2]
+
+mkAppDCo :: DCoercion     -- ^ :: t1 ~r t2
+         -> DCoercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2
+         -> DCoercion     -- ^ :: t1 s1 ~r t2 s2
+mkAppDCo ReflDCo ReflDCo = ReflDCo
+mkAppDCo (TyConAppDCo args) arg = TyConAppDCo (args ++ [arg])
+mkAppDCo co arg = AppDCo co arg
+
+mkAppDCos :: DCoercion
+         -> [DCoercion]
+         -> DCoercion
+mkAppDCos co1 cos = foldl' mkAppDCo co1 cos
+
+-- | Transitivity for directed coercions.
+--
+-- Does some basic simplifications, i.e. either coercion is 'ReflDCo'
+-- or both are 'StepsDCo', but nothing more elaborate.
+mkTransDCo :: DCoercion -> DCoercion -> DCoercion
+  -- NB: if you change this function in an attempt to gain more simplification,
+  -- e.g. simplifying @StepsDCo n `mkTransCo` ( StepsDCo m ; dco )@ to
+  -- @StepsDCo (n+m) ; dco@, check it is not causing significant regressions
+  -- in the rewriter, e.g. T13386.
+mkTransDCo dco1 dco2
+  | isReflDCo dco1
+  = dco2
+  | isReflDCo dco2
+  = dco1
+-- SLD TODO: GRefl cases?
+mkTransDCo (StepsDCo n) (StepsDCo m)
+  = StepsDCo (n+m)
+mkTransDCo dco1 dco2
+  = TransDCo dco1 dco2
+
+-- | 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]
+mkForAllDCo :: TyCoVar -> DCoercionN -> DCoercion -> DCoercion
+mkForAllDCo v kind_dco dco
+  | assert (isTyVar v || almostDevoidCoVarOfDCo v dco) True
+  , isReflDCo dco
+  , isGReflDCo kind_dco
+  = ReflDCo
+mkForAllDCo v kind_dco dco
+  = ForAllDCo v kind_dco dco
+
+-- | 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.
+mkForAllDCo_NoRefl :: TyCoVar -> DCoercionN -> TypeOrConstraint -> DCoercion -> DCoercion
+mkForAllDCo_NoRefl v kind_dco body_torc dco
+  | assert (isTyVar v || almostDevoidCoVarOfDCo v dco) True
+  , assert (not (isReflDCo dco)) True
+  , isCoVar v
+  , not (v `elemVarSet` tyCoVarsOfDCo dco)
+  = let var_torc = case sORTKind_maybe (tyVarKind v) of
+          Just (torc, _) -> torc
+          Nothing -> pprPanic "mkForAllDCo_NoRefl" (ppr v $$ ppr kind_dco)
+        ftf = mkFunTyFlag var_torc body_torc
+    in mkFunDCo ftf mkReflDCo mkReflDCo mkReflDCo kind_dco dco
+      -- Functions from coercions are always unrestricted
+  | otherwise
+  = ForAllDCo v kind_dco dco
+
+-- | Make a Coercion quantified over a type/coercion variable;
+-- the variable has the same type in both sides of the coercion
+mkHomoForAllDCos :: [TyCoVar] -> TypeOrConstraint -> DCoercion -> DCoercion
+mkHomoForAllDCos _ _ ReflDCo = ReflDCo
+mkHomoForAllDCos vs body_torc co = mkHomoForAllDCos_NoRefl vs body_torc co
+
+-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious
+-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.
+mkHomoForAllDCos_NoRefl :: [TyCoVar] -> TypeOrConstraint -> DCoercion -> DCoercion
+mkHomoForAllDCos_NoRefl vs body_torc orig_co
+  = assert (not (isReflDCo orig_co))
+    foldr go orig_co vs
+  where
+    go v co = mkForAllDCo_NoRefl v mkReflDCo body_torc co
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@,
+-- produces @co' :: ty ~r (ty |> co)@
+mkGReflRightDCo :: CoercionN -> DCoercion
+mkGReflRightDCo co
+  | isGReflCo co = mkReflDCo
+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
+    -- instead of @isReflCo@
+  | otherwise    = GReflRightDCo co
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@,
+-- produces @co' :: (ty |> co) ~r ty@
+mkGReflLeftDCo :: CoercionN -> DCoercion
+mkGReflLeftDCo co
+  | isGReflCo co = mkReflDCo
+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@
+    -- instead of @isReflCo@
+  | otherwise    = GReflLeftDCo co
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,
+-- produces @co' :: (ty |> co) ~r ty'
+-- It is not only a utility function, but it saves allocation when co
+-- is a GRefl coercion.
+mkCoherenceLeftDCo :: CoercionN -> DCoercion -> DCoercion
+mkCoherenceLeftDCo co dco
+  | isGReflCo co = dco
+  | otherwise    = GReflLeftDCo co `mkTransDCo` dco
+
+-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
+-- produces @co' :: ty' ~r (ty |> co)
+-- It is not only a utility function, but it saves allocation when co
+-- is a GRefl coercion.
+mkCoherenceRightDCo :: CoercionN -> DCoercion -> DCoercion
+mkCoherenceRightDCo co dco
+  | isGReflCo co = dco
+  | otherwise    = dco `mkTransDCo` GReflRightDCo co
+
+{- Note [Following a directed coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Following a directed coercion means taking a directed coercion `dco`, a role `r`
+and a LHS (input) type `lhs`, and computing the RHS type of the directed coercion,
+`rhs`. This amounts to reconstituting a coercion `co :: lhs ~r rhs` from `dco`.
+
+This process however requires that lhs be sufficiently zonked. For example,
+if `dco = TyConAppDCo`, then we require that `lhs = TyConApp tc tys`, as we need
+to read off the `TyCon` from `lhs` in order to compute the `rhs`.
+
+To avoid any problems, we make sure we never call `followDCo` on an unzonked
+type; that is, we should not call this function from within the typechecker,
+when there are still metavariables floating around.
+-}
+
+-- | Turn a 'DCoercion' into a full 'Coercion' by specifying
+-- a 'Role' and the LHS and RHS 'Type's of the coercion.
+mkHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type -> Coercion
+mkHydrateDCo r l_ty dco r_ty =
+  -- NB: don't assert that r_ty = followDCo r l_ty dco,
+  -- as we sometimes call this function in the typechecker, which means that
+  -- l_ty might not be zonked, in which case followDCo could crash.
+  -- See Note [Following a directed coercion]
+  case dco of
+    ReflDCo        -> mkReflCo r r_ty
+    CoVarDCo cv    -> CoVarCo cv
+    DehydrateCo co -> let co_r = coercionRole co in
+                      assertPpr (r == co_r)
+                        (vcat [ text "mkHydrateCo: role mismatch"
+                              , text "Expected:" <+> ppr r
+                              , text "  Actual:" <+> ppr co_r ])
+                    $ co
+    _ -> HydrateDCo r l_ty dco r_ty
+
+
+fullyHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Coercion
+fullyHydrateDCo r ty dco = fst $ expandDCo r ty dco
+
+hydrateOneLayerDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Coercion
+hydrateOneLayerDCo r l_ty dco = fst $ expandDCoWith hydrate r l_ty dco
+  where
+    hydrate r l_ty dco
+      = let r_ty = followDCo r l_ty dco
+            co = mkHydrateDCo r l_ty dco r_ty
+        in (co, r_ty)
+
+followDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type
+followDCo r ty dco = snd $ expandDCo r ty dco
+
+expandDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> (Coercion, Type)
+expandDCo = expandDCoWith expandDCo
+
+expandDCoWith :: HasDebugCallStack
+          => (Role -> Type -> DCoercion -> (Coercion, Type))
+             -- ^ Function to use to recursively expand nested directed coercions
+          -> Role -> Type -> DCoercion -> (Coercion, Type)
+expandDCoWith _ r ty dco
+  | Just ty' <- coreView ty
+  = expandDCo r ty' dco
+
+expandDCoWith _ r l_ty ReflDCo
+  = (mkReflCo r l_ty, l_ty)
+
+expandDCoWith _ r l_ty (GReflRightDCo kco)
+  | let co = mkGReflCo r l_ty (coToMCo kco)
+  = (co, coercionRKind co)
+
+expandDCoWith _ r l_ty (GReflLeftDCo kco)
+  | let co = mkGReflCo r l_ty (mkSymMCo $ coToMCo kco)
+  -- N.B.: mkSymCo (mkGReflCo r l_ty mco) would be wrong,
+  -- because the LHS type of mco would not be the kind of l_ty.
+  = (co, coercionRKind co)
+
+expandDCoWith expander r l_ty dco@(TyConAppDCo dcos)
+  | Just (tc, l_tys) <- splitTyConApp_maybe l_ty
+  , let (cos, tys) = unzip $ zipWith3 expander (tyConRoleListX r tc) l_tys dcos
+  = (mkTyConAppCo r tc cos, mkTyConApp tc tys)
+  | otherwise
+  = pprPanic "expandDCo" (vcat [ text "TyConAppDCo where type is not a TyCon:"
+                               , text "l_ty:" <+> ppr l_ty
+                               , text "dco:" <+> ppr dco ])
+
+expandDCoWith expander r l_ty (AppDCo dco1 dco2)
+  | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty
+  , let
+      (co1, ty1) = expander r l_ty1 dco1
+      r'
+        | Phantom <- r = Phantom
+        | otherwise    = Nominal
+      (co2, ty2) = expander r' l_ty2 dco2
+  = (mkAppCo co1 co2, mkAppTy ty1 ty2)
+  | otherwise
+  = pprPanic "expandDCo" (text "AppDCo where type is not an AppTy:" <+> ppr l_ty)
+
+expandDCoWith expander r l_ty co@(ForAllDCo tcv kdco body_dco)
+  | not (isTyCoVar tcv)
+  = pprPanic "expandDCo" (text "Non tyco binder in ForAllDCo:" <+> ppr co)
+  | otherwise
+  = case coreFullView l_ty of
+      ForAllTy bndr body_ty
+        | (body_co, rhs_ty) <- expander r body_ty body_dco
+        , let (kco, _) = expandDCoWith expander Nominal (tyVarKind tcv) kdco
+        ->
+          (mkForAllCo tcv kco body_co
+          ,mkForAllTy bndr rhs_ty)
+      _ -> pprPanic "expandDCo" (text "ForAllDCo where type is not a ForAllTy:" <+> ppr l_ty <+> ppr co)
+
+expandDCoWith _ r _ (CoVarDCo cv)
+  = let cv_r = coVarRole cv in
+    assertPpr (r == cv_r)
+      (vcat [ text "expandDCo: wrong role"
+            , text "Expected:" <+> ppr r
+            , text "  Actual:" <+> ppr cv_r
+            , text "cv:" <+> ppr cv ])
+      (CoVarCo cv, coVarRType cv)
+
+expandDCoWith _ r l_ty (AxiomInstDCo ax)
+  = runIdentity $ expandAxiomInstDCo assertPpr (pprPanic "expandDCo") r l_ty ax
+
+expandDCoWith _ r l_ty (StepsDCo 0)
+  = (mkReflCo r l_ty, l_ty)
+
+expandDCoWith expander r l_ty (StepsDCo n)
+  = let (co, ty) = runIdentity $ expandOneStepDCo assertPpr (pprPanic "expandDCo") r l_ty
+        (co', ty') = expandDCoWith expander r ty (StepsDCo (n-1))
+    in (co `mkTransCo` co', ty')
+
+expandDCoWith expander r l_ty (TransDCo dco1 dco2)
+  = let
+      (co1, ty1) = expander r l_ty dco1
+      (co2, ty2) = expander r ty1  dco2
+    in
+      (TransCo co1 co2, ty2)
+
+expandDCoWith expander r l_ty (SubDCo dco)
+  -- Keep expanding one more level through SubDCo.
+  = assert (r == Representational)
+  $ case expandDCoWith expander Nominal l_ty dco of
+      (co, rhs) -> (mkSubCo co, rhs)
+
+expandDCoWith _ r _ (DehydrateCo co)
+  = let co_r = coercionRole co in
+    assertPpr (r == co_r)
+      (vcat [ text "expandDCo: wrong role"
+            , text "Expected:" <+> ppr r
+            , text "  Actual:" <+> ppr co_r
+            , text "co:" <+> ppr co ])
+      (co, coercionRKind co)
+
+expandDCoWith _ r l_ty (UnivDCo prov r_ty)
+  = (UnivCo (expandProv r l_ty prov) r l_ty r_ty, r_ty)
+
+-- | Expand an 'AxiomInstDCo' directed coercion by matching on an open type
+-- or data family instance. (Use 'expandOneStepDCo' for closed type families).
+--
+-- This function is used in both 'expandDCo' (which panics on failure)
+-- and in 'GHC.Core.Lint.lintDCoercion' (which errors in the 'LintM' monad).
+expandAxiomInstDCo :: (HasDebugCallStack, Applicative m)
+                   => (Bool -> SDoc -> m (Coercion, Type) -> m (Coercion, Type))
+                      -- ^ How to check assertions in @m@
+                   -> (SDoc -> m (Coercion, Type))
+                      -- ^ How to throw hard errors in @m@
+                   -> Role -- ^ input role for expansion
+                   -> Type -- ^ input LHS type for expansion
+                   -> CoAxiom Branched -- ^ axiom to use
+                   -> m (Coercion, Type)
+expandAxiomInstDCo check_prop throw_err r l_ty ax
+  | r == Phantom
+  = expandAxiomInstDCo check_prop throw_err Representational l_ty ax
+     -- AMG TODO: think about better fix to the above;
+     -- role could be Phantom because the coercion was downgraded,
+     -- maybe change the following to check role <= rather than exact matches
+
+  | otherwise
+  = case splitTyConApp_maybe l_ty of
+      Just (tc, tys)
+        | let (match_tys, other_tys) = splitAtList ax_lhs $ (map (\ x -> fromMaybe x $ coreView x) tys)
+              debug_info2 = debug_info $$
+                            text "match_tys:" <+> ppr match_tys $$
+                            text "other_tys:" <+> ppr other_tys
+        ->
+        case tcMatchTys ax_lhs match_tys of
+          Just subst ->
+            let inst_tys = substTyVars subst (coAxBranchTyVars branch) `chkAppend` other_tys
+                inst_cos = substCoVars subst (coAxBranchCoVars branch)
+                co = mkUnbranchedAxInstCo r ax' inst_tys inst_cos
+            in check_prop (tc_is_ok tc) (text "AxiomInstDCo: incorrect TyCon for Axiom" $$ debug_info2) $
+               pure (co, coercionRKind co)
+          Nothing ->
+            throw_err (text "AxiomInstDCo: couldn't match axiom" $$ debug_info2)
+      Nothing ->
+        throw_err (text "AxiomInstDCo: lhs not a TyConApp" $$ debug_info)
+  where
+    ax' = toUnbranchedAxiom ax
+    branch = coAxiomSingleBranch ax'
+    ax_lhs = coAxBranchLHS branch
+    tc_is_ok tc = coAxiomTyCon ax == tc &&
+                  case r of
+                    Representational -> isOpenFamilyTyCon     tc
+                    _                -> isOpenTypeFamilyTyCon tc
+    debug_info = vcat [ text "ax:" <+> ppr ax
+                      , text "ax_lhs:" <+> ppr ax_lhs ]
+
+-- | Expand a @StepsDCo 1@ directed coercion by taking a single reduction step,
+-- matching on closed type family equations (and built-in type families), or
+-- unwrapping newtypes (not including data family newtype instances).
+-- (Use 'expandAxiomInstDCo' for open family axioms.)
+--
+-- This function is used in both 'expandDCo' (which panics on failure)
+-- and in 'GHC.Core.Lint.lintDCoercion' (which errors in the 'LintM' monad).
+expandOneStepDCo :: (HasDebugCallStack, Applicative m)
+                 => (Bool -> SDoc -> m (Coercion, Type) -> m (Coercion, Type))
+                      -- ^ How to check assertions in @m@
+                 -> (SDoc -> m (Coercion, Type))
+                      -- ^ How to throw hard errors in @m@
+                 -> Role -- ^ input role for expansion
+                 -> Type -- ^ input LHS type for expansion
+                 -> m (Coercion, Type)
+expandOneStepDCo check_prop throw_err r l_ty
+  = case splitTyConApp_maybe l_ty of
+      Just (tc,tys)
+        -- Closed type family axioms.
+        | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
+        -> case chooseBranch ax tys of
+          Just (ind, inst_tys, inst_cos) ->
+            let
+              co = mkAxInstCo r ax ind inst_tys inst_cos
+              ty = coercionRKind co
+            in pure (co, ty)
+          Nothing ->
+            throw_err
+              (text "StepsDCo: couldn't choose branch" $$ debug_info2 $$ (text "ax:" <+> ppr ax))
+
+        -- Newtype axioms.
+        | Just (ty, co) <- instNewTyCon_maybe tc tys
+        , r == Representational
+        -> pure (co, ty)
+
+        -- Built-in type family axioms.
+        | Just sf <- isBuiltInSynFamTyCon_maybe tc
+        -> case sfMatchFam sf tys of
+             Just (ax, ts, ty) ->
+               let co = mkAxiomRuleCo ax (zipWith mkReflCo (coaxrAsmpRoles ax) ts)
+               in check_prop (r == coaxrRole ax)
+                    (text "StepsDCo: axiom role mismatch" $$ debug_info2 $$ (text "ax:" <+> ppr ax))
+                $ pure (co, ty)
+             Nothing ->
+               throw_err (text "StepsDCo: couldn't match built-in axiom" $$ debug_info2)
+
+        -- Couldn't find any axiom associated to this TyCon.
+        | otherwise
+        -> throw_err (text "StepsDCo: no axiom to use" $$ debug_info2 $$ (text "tc:" <+> ppr tc))
+        where
+          debug_info2 = debug_info $$ (text "tys:" <+> ppr tys)
+
+      -- LHS type is not a TyConApp.
+      Nothing ->
+        throw_err (text "StepsDCo: LHS not a TyConApp" $$ debug_info)
+  where
+    debug_info = vcat [ text "r:" <+> ppr r
+                      , text "l_ty:" <+> ppr l_ty ]
+
+expandProv :: HasDebugCallStack => Role -> Type -> UnivCoProvenance DCoercion -> UnivCoProvenance Coercion
+expandProv r l_ty (PhantomProv dco)
+  = assertPpr (r == Phantom) (text "expandProv PhantomProv")
+  $ PhantomProv (fullyHydrateDCo r l_ty dco)
+expandProv r l_ty (ProofIrrelProv dco)
+  = assertPpr (r /= Phantom) (text "expandProv ProofIrrelProv")
+  $ ProofIrrelProv (fullyHydrateDCo r l_ty dco)
+expandProv _ _ (PluginProv str)
+  = PluginProv str
+expandProv _ _ (CorePrepProv homo)
+  = CorePrepProv homo
+
+mkDehydrateCo :: Coercion -> DCoercion
+mkDehydrateCo co | isReflCo co       = ReflDCo
+mkDehydrateCo (SymCo (GRefl _ _ MRefl))
+                                     = ReflDCo
+mkDehydrateCo (SymCo (GRefl _ _ (MCo co)))
+                                     = mkGReflLeftDCo  co
+mkDehydrateCo (GRefl _ _ MRefl)      = ReflDCo
+mkDehydrateCo (GRefl _ _ (MCo co))   = mkGReflRightDCo co
+mkDehydrateCo (HydrateDCo _ _ dco _) = dco
+--mkDehydrateCo (TyConAppCo _ _ cos)
+--  = mkTyConAppDCo $ map mkDehydrateCo cos
+--mkDehydrateCo (AppCo co1 co2)
+--  = mkAppDCo (mkDehydrateCo co1) (mkDehydrateCo co2)
+--mkDehydrateCo (ForAllCo tcv kind body)
+--  = mkForAllDCo tcv (mkDehydrateCo kind) (mkDehydrateCo body)
+mkDehydrateCo (AxiomInstCo coax _branch cos)
+  | all isReflCo cos -- AMG TODO: can we avoid the need for this check?
+  , isOpenFamilyTyCon (coAxiomTyCon coax)
+  = AxiomInstDCo coax
+  | all isReflCo cos
+  = singleStepDCo
+mkDehydrateCo (AxiomRuleCo _coax cos)
+  | all isReflCo cos  -- AMG TODO: can we avoid the need for this check?
+  = singleStepDCo
+mkDehydrateCo (CoVarCo cv)
+  = CoVarDCo cv
+mkDehydrateCo (SubCo co)
+  = mkSubDCo (coercionLKind co) (mkDehydrateCo co) (coercionRKind co)
+--mkDehydrateCo (TransCo co1 co2)
+--  = mkTransDCo (mkDehydrateCo co1) (mkDehydrateCo co2)
+mkDehydrateCo co
+  = DehydrateCo co
+
+singleStepDCo :: DCoercion
+singleStepDCo = StepsDCo 1
+
+mkUnivDCo :: UnivCoProvenance DCoercion
+          -> Type -- RHS type
+          -> DCoercion
+mkUnivDCo = UnivDCo
+
+mkCoVarDCo :: CoVar -> DCoercion
+mkCoVarDCo v = CoVarDCo v
+
+mkProofIrrelDCo :: DCoercionN -> Type -> DCoercion
+
+-- if the two coercion prove the same fact, I just don't care what
+-- the individual coercions are.
+mkProofIrrelDCo dco rhs
+  | isGReflDCo dco
+  = mkReflDCo
+  | otherwise
+  = mkUnivDCo (ProofIrrelProv dco) rhs
+
 {- Note [Unused coercion variable in ForAllCo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the
@@ -1112,7 +1673,7 @@ mkHoleCo :: CoercionHole -> Coercion
 mkHoleCo h = HoleCo h
 
 -- | Make a universal coercion between two arbitrary types.
-mkUnivCo :: UnivCoProvenance
+mkUnivCo :: UnivCoProvenance KindCoercion
          -> Role       -- ^ role of the built coercion, "r"
          -> Type       -- ^ t1 :: k1
          -> Type       -- ^ t2 :: k2
@@ -1131,6 +1692,8 @@ mkSymCo :: Coercion -> Coercion
 mkSymCo co | isReflCo co          = co
 mkSymCo    (SymCo co)             = co
 mkSymCo    (SubCo (SymCo co))     = SubCo co
+mkSymCo    (HydrateDCo r l_ty (GReflLeftDCo  mco) r_ty) = HydrateDCo r r_ty (GReflRightDCo mco) l_ty
+mkSymCo    (HydrateDCo r l_ty (GReflRightDCo mco) r_ty) = HydrateDCo r r_ty (GReflLeftDCo  mco) l_ty
 mkSymCo co                        = SymCo co
 
 -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
@@ -1140,7 +1703,10 @@ 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
+mkTransCo (HydrateDCo r lhs dco1 _) (HydrateDCo _ _ dco2 rhs)
+  = mkHydrateDCo r lhs (mkTransDCo dco1 dco2) rhs
+mkTransCo dco1 dco2
+  = TransCo dco1 dco2
 
 mkSelCo :: HasDebugCallStack
         => CoSel
@@ -1170,18 +1736,42 @@ mkSelCo_maybe cs co
       -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)
       -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4))
 
+    go SelForAll dco@(HydrateDCo _ _ (ForAllDCo tv kind_co _) rhs)
+      = case splitForAllTyCoVar_maybe rhs of
+          Just (tv', _) -> Just $
+            mkHydrateDCo Nominal (tyVarKind tv) kind_co (tyVarKind tv')
+          _ -> pprPanic "mkSelCo_maybe" (ppr dco $$ ppr rhs)
+
     go (SelFun fs) (FunCo _ _ _ w arg res)
       = Just (getNthFun fs w arg res)
 
+    -- no FunDCo
+
     go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)
       = assertPpr (r == tyConRole r0 tc i)
                   (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $
         Just (arg_cos `getNth` i)
 
+    go (SelTyCon n r) (HydrateDCo r0 l_ty (TyConAppDCo arg_dcos) r_ty)
+      | Just (tc, arg_tys) <- splitTyConApp_maybe l_ty
+      , Just (_, rhs_tys) <- splitTyConApp_maybe r_ty
+      = assertPpr (r == tyConRole r0 tc n)
+        (vcat [ text "tc:" <+> ppr tc
+              , text "arg_dcos:" <+> ppr arg_dcos
+              , text "r0:" <+> ppr r0
+              , text "n:" <+> ppr n
+              , text "r:" <+> ppr r ]) $
+        Just $ mkHydrateDCo
+          (tyConRole r0 tc n)
+          (arg_tys `getNth` n)
+          (arg_dcos `getNth` n)
+          (rhs_tys `getNth` n)
+
     go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo
       = do { co' <- go cs co; return (mkSymCo co') }
 
-    go _ _ = Nothing
+    go _ _
+      = Nothing
 
     -- Assertion checking
     bad_call_msg = vcat [ text "Coercion =" <+> ppr co
@@ -1194,7 +1784,7 @@ mkSelCo_maybe cs co
     good_call SelForAll
       | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1
       , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2
-      =  True
+      = True
 
     good_call (SelFun {})
        = isFunTy ty1 && isFunTy ty2
@@ -1226,6 +1816,13 @@ mkLRCo :: LeftOrRight -> Coercion -> Coercion
 mkLRCo lr co
   | Just (ty, eq) <- isReflCo_maybe co
   = mkReflCo eq (pickLR lr (splitAppTy ty))
+  | AppCo l r <- co
+  = pickLR lr (l,r)
+  | HydrateDCo r l_ty (AppDCo dco1 dco2) r_ty <- co
+  , Just (l_ty_1, l_ty_2) <- splitAppTy_maybe l_ty
+  , Just (r_ty_1, r_ty_2) <- splitAppTy_maybe r_ty
+  = pickLR lr ( mkHydrateDCo r       l_ty_1 dco1 r_ty_1
+              , mkHydrateDCo Nominal l_ty_2 dco2 r_ty_2 )
   | otherwise
   = LRCo lr co
 
@@ -1277,8 +1874,14 @@ mkCoherenceRightCo r ty co co2
 mkKindCo :: Coercion -> Coercion
 mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)
 mkKindCo (GRefl _ _ (MCo co)) = co
+mkKindCo (HydrateDCo _ _ (GReflRightDCo co) _) = co
+mkKindCo (HydrateDCo _ _ (GReflLeftDCo co) _)  = mkSymCo co
 mkKindCo (UnivCo (PhantomProv h) _ _ _)    = h
 mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h
+mkKindCo (HydrateDCo _ lhs (UnivDCo (PhantomProv h) rhs) _)
+  = mkHydrateDCo Nominal (typeKind lhs) h (typeKind rhs)
+mkKindCo (HydrateDCo _ lhs (UnivDCo (ProofIrrelProv h) rhs) _)
+  = mkHydrateDCo Nominal (typeKind lhs) h (typeKind rhs)
 mkKindCo co
   | Pair ty1 ty2 <- coercionKind co
        -- generally, calling coercionKind during coercion creation is a bad idea,
@@ -1302,11 +1905,29 @@ mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })
   = co { fco_role = Representational
        , fco_arg = downgradeRole Representational Nominal arg
        , fco_res = downgradeRole Representational Nominal res }
+mkSubCo (UnivCo p Nominal t1 t2) = UnivCo p Representational t1 t2
+mkSubCo (HydrateDCo _r l_ty dco r_ty)
+  = assertPpr (_r == Nominal)
+      (vcat [ text "mkSubCo (HydrateDCo): unexpected role " <+> ppr _r
+            , text "l_ty:" <+> ppr l_ty
+            , text "dco:" <+> ppr dco ])
+  $ mkHydrateDCo Representational l_ty (mkSubDCo l_ty dco r_ty) r_ty
 mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $
              SubCo co
 
+downgradeDCoToRepresentational :: Role      -- ^ Role of input 'DCoercion'
+                               -> Type      -- ^ LHS type of coercion
+                               -> DCoercion
+                               -> Type      -- ^ RHS type of coercion
+                               -> DCoercion
+downgradeDCoToRepresentational Nominal          lhs dco rhs = mkSubDCo lhs dco rhs
+downgradeDCoToRepresentational Representational _   dco _   = dco
+downgradeDCoToRepresentational Phantom _ dco _
+  = pprPanic "downgradeToRepresentationalDCo: Phantom" (ppr dco)
+
 -- | Changes a role, but only a downgrade. See Note [Role twiddling functions]
-downgradeRole_maybe :: Role   -- ^ desired role
+downgradeRole_maybe :: HasDebugCallStack
+                    => Role   -- ^ desired role
                     -> Role   -- ^ current role
                     -> Coercion -> Maybe Coercion
 -- In (downgradeRole_maybe dr cr co) it's a precondition that
@@ -1324,7 +1945,8 @@ downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)
 
 -- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.
 -- See Note [Role twiddling functions]
-downgradeRole :: Role  -- desired role
+downgradeRole :: HasDebugCallStack
+              => Role  -- desired role
               -> Role  -- current role
               -> Coercion -> Coercion
 downgradeRole r1 r2 co
@@ -1344,10 +1966,12 @@ 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 co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)
+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)
+mkProofIrrelCo r kco  g1 g2
+  = mkUnivCo (ProofIrrelProv kco) r
+      (mkCoercionTy g1) (mkCoercionTy g2)
 
 {-
 %************************************************************************
@@ -1400,14 +2024,54 @@ setNominalRole_maybe r co
           pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)
     setNominalRole_maybe_helper (InstCo co arg)
       = InstCo <$> setNominalRole_maybe_helper co <*> pure arg
+    setNominalRole_maybe_helper (HydrateDCo r ty1 dco mrty)
+      = (\ d -> HydrateDCo Nominal ty1 d mrty) <$> setNominalRole_maybe_dco r ty1 dco
     setNominalRole_maybe_helper (UnivCo prov _ co1 co2)
-      | case prov of PhantomProv _    -> False  -- should always be phantom
-                     ProofIrrelProv _ -> True   -- it's always safe
-                     PluginProv _     -> False  -- who knows? This choice is conservative.
-                     CorePrepProv _   -> True
-      = Just $ UnivCo prov Nominal co1 co2
+      | Just prov' <- setNominalRole_maybe_prov prov
+      = Just $ UnivCo prov' Nominal co1 co2
     setNominalRole_maybe_helper _ = Nothing
 
+setNominalRole_maybe_dco :: Role -> Type -> DCoercion -> Maybe DCoercion
+setNominalRole_maybe_dco _ _ dco@ReflDCo         = pure dco
+setNominalRole_maybe_dco _ _ dco@GReflRightDCo{} = pure dco
+setNominalRole_maybe_dco _ _ dco@GReflLeftDCo{}  = pure dco
+setNominalRole_maybe_dco _ ty (TyConAppDCo dcos)
+  = do { let (tc, tys) = splitTyConApp ty
+       ; dcos' <- zipWith3M setNominalRole_maybe_dco (tyConRoleListX Representational tc) tys dcos
+       ; return $ TyConAppDCo dcos' }
+setNominalRole_maybe_dco r ty  (AppDCo dco1 dco2)
+  = do { let (ty1, _) = splitAppTy ty
+       ; AppDCo <$> setNominalRole_maybe_dco r ty1 dco1 <*> pure dco2
+       }
+setNominalRole_maybe_dco r ty (ForAllDCo tv kind_co dco)
+   = do { let (_, body_ty) = splitForAllTyCoVar ty
+        ; ForAllDCo tv kind_co <$> setNominalRole_maybe_dco r body_ty dco
+        }
+setNominalRole_maybe_dco _ _ CoVarDCo{}                 = Nothing
+setNominalRole_maybe_dco _ _ dco@(AxiomInstDCo coax)
+  | coAxiomRole coax == Nominal         = pure dco
+  | otherwise                           = Nothing
+setNominalRole_maybe_dco _ _ StepsDCo{} = Nothing
+setNominalRole_maybe_dco r ty (TransDCo dco1 dco2)
+  = TransDCo <$> setNominalRole_maybe_dco r ty dco1 <*> setNominalRole_maybe_dco r mid_ty dco2
+  where
+    mid_ty = followDCo r ty dco1
+      -- OK to call followDCo here: this function is always called on fully zonked types.
+setNominalRole_maybe_dco _ _ (SubDCo dco) = Just dco
+setNominalRole_maybe_dco r _ (DehydrateCo co) = DehydrateCo <$> setNominalRole_maybe r co
+setNominalRole_maybe_dco _ _ (UnivDCo prov rhs)
+  | Just prov' <- setNominalRole_maybe_prov prov
+  = Just $ UnivDCo prov' rhs
+  | otherwise
+  = Nothing
+
+setNominalRole_maybe_prov :: UnivCoProvenance co -> Maybe (UnivCoProvenance co)
+setNominalRole_maybe_prov prov = case prov of
+  PhantomProv _    -> Nothing   -- should always be phantom
+  ProofIrrelProv _ -> Just prov -- it's always safe
+  PluginProv _     -> Nothing   -- who knows? This choice is conservative.
+  CorePrepProv _   -> Just prov
+
 -- | Make a phantom coercion between two types. The coercion passed
 -- in must be a nominal coercion between the kinds of the
 -- types.
@@ -1426,6 +2090,17 @@ applyRoles :: TyCon -> [Coercion] -> [Coercion]
 applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational
 
 -- The Role parameter is the Role of the TyConAppCo
+applyRoles_dco :: TyCon -> [Type] -> [DCoercion] -> [Type] -> [DCoercion]
+applyRoles_dco tc l_tys dcos r_tys
+  = zipWith4 downgrade (tyConRoleListRepresentational tc) l_tys dcos r_tys
+  where
+    downgrade r l_ty dco r_ty = case r of
+      Nominal          -> dco
+      Representational -> mkSubDCo l_ty dco r_ty
+      Phantom          -> mkDehydrateCo $ mkPhantomCo (mkKindCo co) l_ty r_ty
+        where
+          co = mkHydrateDCo Nominal l_ty dco r_ty
+
 -- defined here because this is intimately concerned with the implementation
 -- of TyConAppCo
 -- Always returns an infinite list (with a infinite tail of Nominal)
@@ -1532,6 +2207,8 @@ promoteCoercion co = case co of
     UnivCo (PluginProv _)       _ _ _ -> mkKindCo co
     UnivCo (CorePrepProv _)     _ _ _ -> mkKindCo co
 
+    HydrateDCo {} -> mkKindCo co
+
     SymCo g
       -> mkSymCo (promoteCoercion g)
 
@@ -1613,17 +2290,32 @@ instCoercions g ws
       = do { g' <- instCoercion g_tys g w
            ; return (piResultTy <$> g_tys <*> w_tys, g') }
 
+castDCoercionKind2 :: DCoercion -> CoercionN -> CoercionN -> DCoercion
+castDCoercionKind2 g h1 h2
+  = mkCoherenceRightDCo h2 (mkCoherenceLeftDCo h1 g)
+
+castDCoercionKind1 :: DCoercion -> CoercionN -> DCoercion
+castDCoercionKind1 g h
+  = case g of
+      ReflDCo               -> ReflDCo
+      GReflRightDCo kind_co -> GReflRightDCo $
+                                     mkSymCo h `mkTransCo` kind_co `mkTransCo` h
+      GReflLeftDCo kind_co  -> GReflLeftDCo $
+                                     mkSymCo h `mkTransCo` kind_co `mkTransCo` h
+      _                     -> castDCoercionKind2 g h h
+
+
 -- | Creates a new coercion with both of its types casted by different casts
 -- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,
 -- has type @(t1 |> h1) ~r (t2 |> h2)@.
 -- @h1@ and @h2@ must be nominal.
 castCoercionKind2 :: Coercion -> Role -> Type -> Type
-                 -> CoercionN -> CoercionN -> Coercion
+                  -> CoercionN -> CoercionN -> Coercion
 castCoercionKind2 g r t1 t2 h1 h2
   = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)
 
--- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@
--- That is, it's a specialised form of castCoercionKind, where the two
+-- | @castCoercionKind1 g r t1 t2 h@ = @castCoercionKind2 g r t1 t2 h h@
+-- That is, it's a specialised form of castCoercionKind2, where the two
 --          kind coercions are identical
 -- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,
 -- has type @(t1 |> h) ~r (t2 |> h)@.
@@ -1950,7 +2642,8 @@ type LiftCoEnv = VarEnv Coercion
      -- Also maps coercion variables to ProofIrrelCos.
 
 -- like liftCoSubstWith, but allows for existentially-bound types as well
-liftCoSubstWithEx :: Role          -- desired role for output coercion
+liftCoSubstWithEx :: HasDebugCallStack
+                  => Role          -- desired role for output coercion
                   -> [TyVar]       -- universally quantified tyvars
                   -> [Coercion]    -- coercions to substitute for those
                   -> [TyCoVar]     -- existentially quantified tycovars
@@ -2054,13 +2747,25 @@ zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv
 
 -- | Like 'substForAllCoBndr', but works on a lifting context
 substForAllCoBndrUsingLC :: Bool
-                            -> (Coercion -> Coercion)
-                            -> LiftingContext -> TyCoVar -> Coercion
-                            -> (LiftingContext, TyCoVar, Coercion)
-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
+                         -> (Type -> Type)
+                         -> (Coercion -> Coercion)
+                         -> LiftingContext -> TyCoVar -> Coercion
+                         -> (LiftingContext, TyCoVar, Coercion)
+substForAllCoBndrUsingLC sym sty sco (LC subst lc_env) tv co
+  = (LC subst' lc_env, tv', co')
+  where
+    (subst', tv', co') = substForAllCoBndrUsing Co sym sty sco subst tv co
+
+-- | Like 'substForAllDCoBndr', but works on a lifting context
+substForAllDCoBndrUsingLC :: Bool
+                         -> (Type -> Type)
+                         -> (DCoercion -> DCoercion)
+                         -> LiftingContext -> TyCoVar -> DCoercion
+                         -> (LiftingContext, TyCoVar, DCoercion)
+substForAllDCoBndrUsingLC sym sty sco (LC subst lc_env) tv co
   = (LC subst' lc_env, tv', co')
   where
-    (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co
+    (subst', tv', co') = substForAllCoBndrUsing DCo sym sty sco subst tv co
 
 -- | The \"lifting\" operation which substitutes coercions for type
 --   variables in a type to produce a coercion.
@@ -2229,6 +2934,9 @@ liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var
     eta      = view_co stuff
     k1       = coercionLKind eta
     new_var  = uniqAway (getSubstInScope subst) (setVarType old_var k1)
+      -- SLD TODO (LC): we should be able to get rid of this call to 'setVarType',
+      -- and thus remove this call to 'coercionLKind' entirely, if we don't store
+      -- the kind of the variable in ForAllCo/ForAllDCo.
 
     -- old_var :: s1  ~r s2
     -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)
@@ -2338,8 +3046,9 @@ seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq`
 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 (HydrateDCo r t1 dco rty) = r `seq` seqType t1 `seq` seqDCo dco `seq` seqType rty
+seqCo (UnivCo p r t1 t2)        = seqProv seqCo p `seq` r `seq` seqType t1
+                                                          `seq` seqType t2
 seqCo (SymCo co)                = seqCo co
 seqCo (TransCo co1 co2)         = seqCo co1 `seq` seqCo co2
 seqCo (SelCo n co)              = n `seq` seqCo co
@@ -2349,16 +3058,37 @@ seqCo (KindCo co)               = seqCo co
 seqCo (SubCo co)                = seqCo co
 seqCo (AxiomRuleCo _ cs)        = seqCos cs
 
-seqProv :: UnivCoProvenance -> ()
-seqProv (PhantomProv co)    = seqCo co
-seqProv (ProofIrrelProv co) = seqCo co
-seqProv (PluginProv _)      = ()
-seqProv (CorePrepProv _)    = ()
+seqDCo :: DCoercion -> ()
+seqDCo  ReflDCo            = ()
+seqDCo (GReflRightDCo co)  = seqCo co
+seqDCo (GReflLeftDCo  co)  = seqCo co
+seqDCo (TyConAppDCo  cos)  = seqDCos cos
+seqDCo (AppDCo co1 co2)    = seqDCo co1 `seq` seqDCo co2
+seqDCo (ForAllDCo tv k co) = seqType (varType tv) `seq` seqDCo k
+                                                  `seq` seqDCo co
+seqDCo (CoVarDCo cv)       = cv `seq` ()
+seqDCo (AxiomInstDCo con)  = con `seq` ()
+seqDCo StepsDCo{}          = ()
+seqDCo (TransDCo co1 co2)  = seqDCo co1 `seq` seqDCo co2
+seqDCo (SubDCo co)         = seqDCo co
+seqDCo (DehydrateCo co)    = seqCo co
+seqDCo (UnivDCo prov rhs)  = seqProv seqDCo prov `seq` seqType rhs
+
+seqProv :: (co -> ()) -> UnivCoProvenance co -> ()
+seqProv seq_co (PhantomProv co)    = seq_co co
+seqProv seq_co (ProofIrrelProv co) = seq_co co
+seqProv _      (PluginProv _)      = ()
+seqProv _      (CorePrepProv _)    = ()
 
 seqCos :: [Coercion] -> ()
 seqCos []       = ()
 seqCos (co:cos) = seqCo co `seq` seqCos cos
 
+seqDCos :: [DCoercion] -> ()
+seqDCos []       = ()
+seqDCos (co:cos) = seqDCo co `seq` seqDCos cos
+
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -2404,6 +3134,7 @@ coercionLKind co
     go (CoVarCo cv)              = coVarLType cv
     go (HoleCo h)                = coVarLType (coHoleCoVar h)
     go (UnivCo _ _ ty1 _)        = ty1
+    go (HydrateDCo _ ty1 _ _)    = ty1
     go (SymCo co)                = coercionRKind co
     go (TransCo co1 _)           = go co1
     go (LRCo lr co)              = pickLR lr (splitAppTy (go co))
@@ -2465,6 +3196,7 @@ coercionRKind co
        {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult
                                          , ft_arg = go arg, ft_res = go res }
     go (UnivCo _ _ _ ty2)        = ty2
+    go (HydrateDCo _ _ _ rty)    = rty
     go (SymCo co)                = coercionLKind co
     go (TransCo _ co2)           = go co2
     go (LRCo lr co)              = pickLR lr (splitAppTy (go co))
@@ -2571,6 +3303,7 @@ coercionRole = go
     go (CoVarCo cv) = coVarRole cv
     go (HoleCo h)   = coVarRole (coHoleCoVar h)
     go (AxiomInstCo ax _ _) = coAxiomRole ax
+    go (HydrateDCo r _ _ _) = r
     go (UnivCo _ r _ _)  = r
     go (SymCo co) = go co
     go (TransCo co1 _co2) = go co1
@@ -2747,7 +3480,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
 
 has_co_hole_ty :: Type -> Monoid.Any
 has_co_hole_co :: Coercion -> Monoid.Any
-(has_co_hole_ty, _, has_co_hole_co, _)
+(has_co_hole_ty, _, has_co_hole_co, _, _, _)
   = foldTyCo folder ()
   where
     folder = TyCoFolder { tcf_view  = noView
@@ -2770,7 +3503,7 @@ hasCoercionHoleCo = Monoid.getAny . has_co_hole_co
 hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool
 hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty)
   where
-    (f, _, _, _) = foldTyCo folder ()
+    (f, _, _, _, _, _) = foldTyCo folder ()
 
     folder = TyCoFolder { tcf_view  = noView
                         , tcf_tyvar = const2 (Monoid.Any False)
diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot
index 276a48cf81..6430e3f6ee 100644
--- a/compiler/GHC/Core/Coercion.hs-boot
+++ b/compiler/GHC/Core/Coercion.hs-boot
@@ -23,7 +23,7 @@ mkFunCo2     :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coerc
 mkCoVarCo :: CoVar -> Coercion
 mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
 mkPhantomCo :: Coercion -> Type -> Type -> Coercion
-mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion
+mkUnivCo :: UnivCoProvenance Coercion -> Role -> Type -> Type -> Coercion
 mkSymCo :: Coercion -> Coercion
 mkTransCo :: Coercion -> Coercion -> Coercion
 mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion
@@ -38,6 +38,20 @@ mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
 
 funRole :: Role -> FunSel -> Role
 
+mkTyConAppDCo :: [DCoercion] -> DCoercion
+mkAppDCo :: DCoercion -> DCoercion -> DCoercion
+mkTransDCo :: DCoercion -> DCoercion -> DCoercion
+mkForAllDCo :: TyCoVar -> DCoercion -> DCoercion -> DCoercion
+mkReflDCo :: DCoercion
+mkGReflRightDCo :: CoercionN -> DCoercion
+mkGReflLeftDCo :: CoercionN -> DCoercion
+mkDehydrateCo :: Coercion -> DCoercion
+mkHydrateDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type -> Coercion
+mkCoVarDCo :: CoVar -> DCoercion
+mkUnivDCo :: UnivCoProvenance DCoercion -> Type -> DCoercion
+mkSubDCo :: HasDebugCallStack => Type -> DCoercion -> Type -> DCoercion
+followDCo :: HasDebugCallStack => Role -> Type -> DCoercion -> Type
+
 isGReflCo :: Coercion -> Bool
 isReflCo :: Coercion -> Bool
 isReflexiveCo :: Coercion -> Bool
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 98506c444e..8df3dc31e5 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -1,10 +1,15 @@
 -- (c) The University of Glasgow 2006
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module GHC.Core.Coercion.Opt
    ( optCoercion
    , OptCoercionOpts (..)
+   , OptDCoMethod (..)
    )
 where
 
@@ -21,6 +26,7 @@ import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
 import GHC.Core.Unify
 
+import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Unique.Set
@@ -35,6 +41,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
 import Control.Monad   ( zipWithM )
+import qualified Data.Kind ( Type )
 
 {-
 %************************************************************************
@@ -123,31 +130,40 @@ So we substitute the coercion variable c for the coercion
 
 -- | Coercion optimisation options
 newtype OptCoercionOpts = OptCoercionOpts
-   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)
+   { optCoercionOpts :: Maybe OptDCoMethod
+       -- ^ @Nothing@: no coercion optimisation.
+       -- ^ @Just opt@: do full coercion optimisation, with @opt@ specifying
+       --   how to deal with directed coercions.
    }
 
+data OptDCoMethod
+  = HydrateDCos
+      -- ^ Turn directed coercions back into fully-fledged coercions in the
+      -- coercion optimiser, so that they can be fully optimised.
+  | OptDCos
+      -- ^ Optimise directed coercions with the (currently limited)
+      -- forms of optimisation avaiable for directed coercions.
+      { skipDCoOpt :: !Bool
+        -- ^ Whether to skip optimisation of directed coercions entirely
+        -- when possible.
+        }
+
+data OptCoParams =
+  OptCoParams { optDCoMethod :: !OptDCoMethod }
+
 optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo
 -- ^ optCoercion applies a substitution to a coercion,
 --   *and* optimises it to reduce its size
-optCoercion opts env co
-  | optCoercionEnabled opts
-  = optCoercion' env co
-{-
-  = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $
-    let result = optCoercion' env co in
-    pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co
-                                   , text "Optco:" <+> ppr result ]) $
-    result
--}
-
-  | otherwise
-  = substCo env co
-
-
-optCoercion' :: Subst -> Coercion -> NormalCo
-optCoercion' env co
+optCoercion (OptCoercionOpts opts) env co
+  | Just dco_method <- opts = optCoercion'
+                                (OptCoParams { optDCoMethod = dco_method }) env
+                            $ co
+  | otherwise               = substCo env $ co
+
+optCoercion' :: OptCoParams -> Subst -> Coercion -> NormalCo
+optCoercion' opts env co
   | debugIsOn
-  = let out_co = opt_co1 lc False co
+  = let out_co = opt_co1 opts lc False co
         (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co
         (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
     in
@@ -167,7 +183,7 @@ optCoercion' env co
                           , text "subst:" <+> ppr env ]))
                out_co
 
-  | otherwise         = opt_co1 lc False co
+  | otherwise         = opt_co1 opts lc False co
   where
     lc = mkSubstLiftingContext env
     ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)
@@ -179,7 +195,10 @@ type NormalCo    = Coercion
   --  * For trans coercions (co1 `trans` co2)
   --       co1 is not a trans, and neither co1 nor co2 is identity
 
+type NormalDCo = DCoercion
+
 type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity
+type NormalNonIdDCo = NormalDCo  -- Extra invariant: not the identity
 
 -- | Do we apply a @sym@ to the result?
 type SymFlag = Bool
@@ -189,65 +208,71 @@ type ReprFlag = Bool
 
 -- | Optimize a coercion, making no assumptions. All coercions in
 -- the lifting context are already optimized (and sym'd if nec'y)
-opt_co1 :: LiftingContext
+opt_co1 :: OptCoParams
+        -> LiftingContext
         -> SymFlag
         -> Coercion -> NormalCo
-opt_co1 env sym co = opt_co2 env sym (coercionRole co) co
+opt_co1 opts env sym co = opt_co2 opts env sym (coercionRole co) co
 
 -- See Note [Optimising coercion optimisation]
 -- | Optimize a coercion, knowing the coercion's role. No other assumptions.
-opt_co2 :: LiftingContext
+opt_co2 :: OptCoParams
+        -> LiftingContext
         -> SymFlag
         -> Role   -- ^ The role of the input coercion
         -> Coercion -> NormalCo
-opt_co2 env sym Phantom co = opt_phantom env sym co
-opt_co2 env sym r       co = opt_co3 env sym Nothing r co
+opt_co2 opts env sym Phantom co = opt_phantom opts env sym co
+opt_co2 opts env sym r       co = opt_co3 opts env sym Nothing r co
 
 -- See Note [Optimising coercion optimisation]
 -- | Optimize a coercion, knowing the coercion's non-Phantom role.
-opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo
-opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co
-opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True  r co
+opt_co3 :: OptCoParams -> LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo
+opt_co3 opts env sym (Just Phantom)          _ co = opt_phantom opts env sym co
+opt_co3 opts env sym (Just Representational) r co = opt_co4 opts env sym True  r co
   -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore
-opt_co3 env sym _                       r co = opt_co4_wrap env sym False r co
+opt_co3 opts env sym _                       r co = opt_co4 opts env sym False r co
+
+-- | Utility function for debugging coercion optimisation: uncomment
+-- the logging functions in the body of this function, and the coercion
+-- optimiser will produce a log of what it is doing.
+wrap :: (Outputable in_co, Outputable out_co) => String -> Optimiser in_co out_co -> Optimiser in_co out_co
+wrap _str opt_thing opts env sym rep r co
+  = {- pprTrace (_str ++ " wrap {")
+    ( vcat [ text "Sym:" <+> ppr sym
+           , text "Rep:" <+> ppr rep
+           , text "Role:" <+> ppr r
+           , text "Co:" <+> ppr co
+           , text "LC:" <+> ppr env
+           , text "Subst:" <+> ppr (lcTCvSubst env)]) $
+    --assert (r == coercionRole co)
+    pprTrace (_str ++ " wrap }") (ppr co $$ text "---" $$ ppr result) $ -}
+    result
+  where result = opt_thing opts env sym rep r co
 
 -- See Note [Optimising coercion optimisation]
 -- | Optimize a non-phantom coercion.
-opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag
-                      -> Role -> Coercion -> NormalCo
+opt_co4_wrap :: String -> OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo
 -- Precondition: In every call (opt_co4 lc sym rep role co)
 --               we should have role = coercionRole co
-opt_co4_wrap = opt_co4
-
-{-
-opt_co4_wrap env sym rep r co
-  = pprTrace "opt_co4_wrap {"
-    ( vcat [ text "Sym:" <+> ppr sym
-           , text "Rep:" <+> ppr rep
-           , text "Role:" <+> ppr r
-           , text "Co:" <+> ppr co ]) $
-    assert (r == coercionRole co )    $
-    let result = opt_co4 env sym rep r co in
-    pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $
-    result
--}
 
+opt_co4_wrap str opts env sym rep r co = wrap ("opt_co4 " ++ str) opt_co4 opts env sym rep r co
 
-opt_co4 env _   rep r (Refl ty)
+opt_co4 :: OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo
+opt_co4 _ env _   rep r (Refl ty)
   = assertPpr (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)
+opt_co4 _ env _   rep r (GRefl _r ty MRefl)
   = assertPpr (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))
+opt_co4 opts env sym  rep r (GRefl _r ty (MCo co))
   = assertPpr (r == _r)
               (text "Expected role:" <+> ppr r $$
                text "Found role:" <+> ppr _r   $$
@@ -258,58 +283,58 @@ opt_co4 env sym  rep r (GRefl _r ty (MCo co))
   where
     r'  = chooseRole rep r
     ty' = substTy (lcSubstLeft env) ty
-    co' = opt_co4 env False False Nominal co
+    co' = opt_co4 opts env False False Nominal co
 
-opt_co4 env sym rep r (SymCo co)  = opt_co4_wrap env (not sym) rep r co
+opt_co4 opts env sym rep r (SymCo co)  = opt_co4_wrap "SymCo" opts 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,
   -- which treat their left and right sides differently. We don't want to
   -- exchange them.
 
-opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
+opt_co4 opts env sym rep r g@(TyConAppCo _r tc cos)
   = assert (r == _r) $
     case (rep, r) of
       (True, Nominal) ->
         mkTyConAppCo Representational tc
-                     (zipWith3 (opt_co3 env sym)
+                     (zipWith3 (opt_co3 opts env sym)
                                (map Just (tyConRoleListRepresentational tc))
                                (repeat Nominal)
                                cos)
       (False, Nominal) ->
-        mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)
+        mkTyConAppCo Nominal tc (map (opt_co4_wrap "TyConAppCo (False, Nominal)" opts env sym False Nominal) cos)
       (_, Representational) ->
                       -- must use opt_co2 here, because some roles may be P
                       -- See Note [Optimising coercion optimisation]
-        mkTyConAppCo r tc (zipWith (opt_co2 env sym)
+        mkTyConAppCo r tc (zipWith (opt_co2 opts env sym)
                                    (tyConRoleListRepresentational tc)  -- the current roles
                                    cos)
       (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)
 
-opt_co4 env sym rep r (AppCo co1 co2)
-  = mkAppCo (opt_co4_wrap env sym rep r co1)
-            (opt_co4_wrap env sym False Nominal co2)
+opt_co4 opts env sym rep r (AppCo co1 co2)
+  = mkAppCo (opt_co4_wrap "AppCo co1" opts env sym rep r co1)
+            (opt_co4_wrap "AppCo co2" opts env sym False Nominal co2)
 
-opt_co4 env sym rep r (ForAllCo tv k_co co)
-  = case optForAllCoBndr env sym tv k_co of
+opt_co4 opts env sym rep r (ForAllCo tv k_co co)
+  = case optForAllCoBndr opts env sym tv k_co of
       (env', tv', k_co') -> mkForAllCo tv' k_co' $
-                            opt_co4_wrap env' sym rep r co
+                            opt_co4_wrap "ForAllCo" opts env' sym rep r co
      -- Use the "mk" functions to check for nested Refls
 
-opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2)
+opt_co4 opts env sym rep r (FunCo _r afl afr cow co1 co2)
   = assert (r == _r) $
     mkFunCo2 r' afl' afr' cow' co1' co2'
   where
-    co1' = opt_co4_wrap env sym rep r co1
-    co2' = opt_co4_wrap env sym rep r co2
-    cow' = opt_co1 env sym cow
+    co1' = opt_co4_wrap "FunCo co1" opts env sym rep r co1
+    co2' = opt_co4_wrap "FunCo co2" opts env sym rep r co2
+    cow' = opt_co1 opts env sym cow
     !r' | rep       = Representational
         | otherwise = r
     !(afl', afr') | sym       = (afr,afl)
                   | otherwise = (afl,afr)
 
-opt_co4 env sym rep r (CoVarCo cv)
+opt_co4 opts env sym rep r (CoVarCo cv)
   | Just co <- lookupCoVar (lcSubst env) cv
-  = opt_co4_wrap (zapLiftingContext env) sym rep r co
+  = opt_co4_wrap "CoVarCo" opts (zapLiftingContext env) sym rep r co
 
   | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]
   = mkReflCo (chooseRole rep r) ty1
@@ -330,10 +355,10 @@ opt_co4 env sym rep r (CoVarCo cv)
                           cv
           -- cv1 might have a substituted kind!
 
-opt_co4 _ _ _ _ (HoleCo h)
+opt_co4 _ _ _ _ _ (HoleCo h)
   = pprPanic "opt_univ fell into a hole" (ppr h)
 
-opt_co4 env sym rep r (AxiomInstCo con ind cos)
+opt_co4 opts env sym rep r (AxiomInstCo con ind cos)
     -- Do *not* push sym inside top-level axioms
     -- e.g. if g is a top-level axiom
     --   g a : f a ~ a
@@ -343,43 +368,64 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos)
     wrapSym sym $
                        -- some sub-cos might be P: use opt_co2
                        -- See Note [Optimising coercion optimisation]
-    AxiomInstCo con ind (zipWith (opt_co2 env False)
+    AxiomInstCo con ind (zipWith (opt_co2 opts env False)
                                  (coAxBranchRoles (coAxiomNthBranch con ind))
                                  cos)
       -- Note that the_co does *not* have sym pushed into it
 
-opt_co4 env sym rep r (UnivCo prov _r t1 t2)
-  = assert (r == _r )
-    opt_univ env sym prov (chooseRole rep r) t1 t2
+opt_co4 opts env@(LC _ _lift_co_env) sym rep r (HydrateDCo _r lhs_ty dco rhs_ty)
+  = case optDCoMethod opts of
+      HydrateDCos ->
+        opt_co4 opts env sym rep r (hydrateOneLayerDCo r lhs_ty dco)
+      OptDCos { skipDCoOpt = do_skip }
+        | do_skip && isEmptyVarEnv _lift_co_env
+        -> let res = substCo (lcSubst env) (HydrateDCo r lhs_ty dco rhs_ty)
+        in assert (r == _r) $
+           wrapSym sym $
+           wrapRole rep r $
+           res
+        | otherwise
+        -> assert (r == _r) $
+             wrapSym sym $
+             (\ (lhs', dco') -> mkHydrateDCo r' lhs' dco' rhs') $
+             opt_dco4_wrap "HydrateDCo" opts env rep r lhs_ty dco
+  where
+    rhs' = substTyUnchecked (lcSubstRight env) rhs_ty
+    r'   = chooseRole rep r
+
+opt_co4 opts env sym rep r (UnivCo prov _r t1 t2)
+  = assert (r == _r) $
+    opt_univ Co opts env sym prov (chooseRole rep r) t1 t2
 
-opt_co4 env sym rep r (TransCo co1 co2)
+opt_co4 opts env sym rep r (TransCo co1 co2)
                       -- sym (g `o` h) = sym h `o` sym g
-  | sym       = opt_trans in_scope co2' co1'
-  | otherwise = opt_trans in_scope co1' co2'
+  | sym       = opt_trans opts in_scope co2' co1'
+  | otherwise = opt_trans opts in_scope co1' co2'
+
   where
-    co1' = opt_co4_wrap env sym rep r co1
-    co2' = opt_co4_wrap env sym rep r co2
+    co1' = opt_co4_wrap "TransCo co1" opts env sym rep r co1
+    co2' = opt_co4_wrap "TransCo co2" opts env sym rep r co2
     in_scope = lcInScopeSet env
 
-opt_co4 env _sym rep r (SelCo n co)
+opt_co4 _ env _sym rep r (SelCo n co)
   | Just (ty, _co_role) <- isReflCo_maybe co
   = liftCoSubst (chooseRole rep r) env (getNthFromType n ty)
     -- NB: it is /not/ true that r = _co_role
     --     Rather, r = coercionRole (SelCo n co)
 
-opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos))
+opt_co4 opts env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos))
   = assert (r == r1 )
-    opt_co4_wrap env sym rep r (cos `getNth` n)
+    opt_co4_wrap "SelTyCon" opts env sym rep r (cos `getNth` n)
 
 -- see the definition of GHC.Builtin.Types.Prim.funTyCon
-opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2))
-  = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2)
+opt_co4 opts env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2))
+  = opt_co4_wrap "SelFun" opts env sym rep r (getNthFun fs w co1 co2)
 
-opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _))
+opt_co4 opts env sym rep _ (SelCo SelForAll (ForAllCo _ eta _))
       -- works for both tyvar and covar
-  = opt_co4_wrap env sym rep Nominal eta
+  = opt_co4_wrap "SelForAll" opts env sym rep Nominal eta
 
-opt_co4 env sym rep r (SelCo n co)
+opt_co4 opts env sym rep r (SelCo n co)
   | Just nth_co <- case (co', n) of
       (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n)
       (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2)
@@ -387,71 +433,73 @@ opt_co4 env sym rep r (SelCo n co)
       _                  -> Nothing
   = if rep && (r == Nominal)
       -- keep propagating the SubCo
-    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co
+    then opt_co4_wrap "NthCo" opts (zapLiftingContext env) False True Nominal nth_co
     else nth_co
 
   | otherwise
   = wrapRole rep r $ SelCo n co'
   where
-    co' = opt_co1 env sym co
+    co' = opt_co1 opts env sym co
 
-opt_co4 env sym rep r (LRCo lr co)
+opt_co4 opts env sym rep r (LRCo lr co)
   | Just pr_co <- splitAppCo_maybe co
   = assert (r == Nominal )
-    opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)
+    opt_co4_wrap "LrCO AppCo" opts env sym rep Nominal (pick_lr lr pr_co)
   | Just pr_co <- splitAppCo_maybe co'
   = assert (r == Nominal) $
     if rep
-    then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)
+    then opt_co4_wrap "LrCo AppCo'" opts (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)
     else pick_lr lr pr_co
   | otherwise
   = wrapRole rep Nominal $ LRCo lr co'
   where
-    co' = opt_co4_wrap env sym False Nominal co
+    co' = opt_co4_wrap "LrCo co'" opts env sym False Nominal co
 
     pick_lr CLeft  (l, _) = l
     pick_lr CRight (_, r) = r
 
 -- See Note [Optimising InstCo]
-opt_co4 env sym rep r (InstCo co1 arg)
+opt_co4 opts env sym rep r (InstCo co1 arg)
     -- forall over type...
   | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1
-  = opt_co4_wrap (extendLiftingContext env tv
-                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))
-                   -- mkSymCo kind_co :: k1 ~ k2
-                   -- sym_arg :: (t1 :: k1) ~ (t2 :: k2)
-                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)
-                 sym rep r co_body
+  = opt_co4_wrap "InstCo ForAllTy" opts
+        (extendLiftingContext env tv
+          (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))
+            -- mkSymCo kind_co :: k1 ~ k2
+            -- sym_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
+  = let new_co = mk_new_co cv (opt_co4_wrap "InstCo kind_co" opts env sym False Nominal kind_co) h1 h2
+    in opt_co4_wrap "InstCo ForAllCo" opts (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_ty_maybe co1'
-  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'
-                    (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))
-            False False r' co_body'
+  = opt_co4_wrap "InstCo ForAllTy 2" opts
+      (extendLiftingContext (zapLiftingContext env) tv'
+        (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)
+    in opt_co4_wrap "InstCo ForAllCo 2" opts (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
+    co1'    = opt_co4_wrap "InstCo recur co1" opts env sym rep r co1
     r'      = chooseRole rep r
-    arg'    = opt_co4_wrap env sym False Nominal arg
+    arg'    = opt_co4_wrap "InstCo recur arg" opts env sym False Nominal arg
     sym_arg = wrapSym sym arg'
 
     -- Performance note: don't be alarmed by the two calls to coercionKind
@@ -479,25 +527,28 @@ opt_co4 env sym rep r (InstCo co1 arg)
          in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1
                            (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))
 
-opt_co4 env sym _rep r (KindCo co)
+opt_co4 opts env sym _rep r (KindCo co)
   = assert (r == Nominal) $
     let kco' = promoteCoercion co in
     case kco' of
-      KindCo co' -> promoteCoercion (opt_co1 env sym co')
-      _          -> opt_co4_wrap env sym False Nominal kco'
+      KindCo co' -> promoteCoercion (opt_co1 opts env sym co')
+      _          -> opt_co4_wrap "KindCo" opts env sym False Nominal kco'
   -- This might be able to be optimized more to do the promotion
   -- and substitution/optimization at the same time
 
-opt_co4 env sym _ r (SubCo co)
-  = assert (r == Representational) $
-    opt_co4_wrap env sym True Nominal co
+opt_co4 opts env sym _ _r (SubCo co)
+  = assert (_r == Representational) $
+    let res = opt_co4_wrap "SubCo" opts env sym True Nominal co
+    in case coercionRole res of
+         Nominal -> SubCo res
+         _       -> res
 
 -- This could perhaps be optimized more.
-opt_co4 env sym rep r (AxiomRuleCo co cs)
+opt_co4 opts env sym rep r (AxiomRuleCo co cs)
   = assert (r == coaxrRole co) $
     wrapRole rep r $
     wrapSym sym $
-    AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)
+    AxiomRuleCo co (zipWith (opt_co2 opts env False) (coaxrAsmpRoles co) cs)
 
 {- Note [Optimise CoVarCo to Refl]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -511,9 +562,9 @@ in GHC.Core.Coercion.
 -------------
 -- | Optimize a phantom coercion. The input coercion may not necessarily
 -- be a phantom, but the output sure will be.
-opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo
-opt_phantom env sym co
-  = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2
+opt_phantom :: OptCoParams -> LiftingContext -> SymFlag -> Coercion -> NormalCo
+opt_phantom opts env sym co
+  = opt_univ Co opts env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2
   where
     Pair ty1 ty2 = coercionKind co
 
@@ -548,17 +599,41 @@ See #19509.
 
  -}
 
-opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
-         -> Type -> Type -> Coercion
-opt_univ env sym (PhantomProv h) _r ty1 ty2
-  | sym       = mkPhantomCo h' ty2' ty1'
-  | otherwise = mkPhantomCo h' ty1' ty2'
+type OptRes :: Data.Kind.Type -> Data.Kind.Type
+type family OptRes co_or_dco where
+  OptRes Coercion  = Coercion
+  OptRes DCoercion = ( Type, DCoercion )
+
+type Optimiser in_co out_co =
+      OptCoParams -> LiftingContext -> SymFlag -> ReprFlag -> Role -> in_co -> out_co
+
+opt_co_or_dco :: CoOrDCo co_or_dco -> Type -> Optimiser co_or_dco co_or_dco
+opt_co_or_dco Co  _    = opt_co4
+opt_co_or_dco DCo l_ty = \ opts lc sym repr r dco ->
+  assert (sym == False) $
+  snd $
+  opt_dco4 opts lc repr r l_ty dco
+
+opt_univ :: forall co_or_dco
+         .  Outputable co_or_dco
+         => CoOrDCo co_or_dco
+         -> OptCoParams
+         -> LiftingContext -> SymFlag -> UnivCoProvenance co_or_dco -> Role
+         -> Type -> Type -> OptRes co_or_dco
+opt_univ co_or_dco opts env sym (PhantomProv h) _r ty1 ty2
+  | sym       = mk_phantom h' ty2' ty1'
+  | otherwise = mk_phantom h' ty1' ty2'
   where
-    h' = opt_co4 env sym False Nominal h
+    h' = wrap "opt_univ PhantomProv" (opt_co_or_dco co_or_dco ty1) opts env sym False Nominal h
     ty1' = substTy (lcSubstLeft  env) ty1
     ty2' = substTy (lcSubstRight env) ty2
 
-opt_univ env sym prov role oty1 oty2
+    mk_phantom :: co_or_dco -> Type -> Type -> OptRes co_or_dco
+    mk_phantom = case co_or_dco of
+      Co  -> mkPhantomCo
+      DCo -> \ h t1 t2 -> (t1, mkUnivDCo (PhantomProv h) t2)
+
+opt_univ co_or_dco opts env sym prov role oty1 oty2
   | Just (tc1, tys1) <- splitTyConApp_maybe oty1
   , Just (tc2, tys2) <- splitTyConApp_maybe oty2
   , tc1 == tc2
@@ -567,10 +642,19 @@ 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    = tyConRoleListX role tc1
-        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'
+    in case co_or_dco of
+          Co ->
+            let
+              arg_cos  = zipWith3 mk_univ roles tys1 tys2
+              arg_cos' = zipWith (opt_co4 opts env sym False) roles arg_cos
+            in
+              mkTyConAppCo role tc1 arg_cos'
+          DCo ->
+            let
+              arg_cos  = zipWith3 (\ r x y -> snd $ mk_univ r x y) roles tys1 tys2
+              (arg_lhs', arg_dcos') = unzip $ zipWith3 (opt_dco4 opts env False) roles tys1 arg_cos
+            in
+              (mkTyConApp tc1 arg_lhs', mkTyConAppDCo arg_dcos')
 
   -- can't optimize the AppTy case because we can't build the kind coercions.
 
@@ -579,13 +663,16 @@ opt_univ env sym prov role oty1 oty2
       -- NB: prov isn't interesting here either
   = let k1   = tyVarKind tv1
         k2   = tyVarKind tv2
-        eta  = mkUnivCo prov' Nominal k1 k2
+        eta  = case co_or_dco of
+                 Co  -> mk_univ Nominal k1 k2
+                 DCo -> snd $ mk_univ Nominal k1 k2
+        tv1' = mk_castTy (TyVarTy tv1) k1 eta k2
           -- eta gets opt'ed soon, but not yet.
-        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2
+        ty2' = substTyWith [tv2] [tv1'] ty2
 
-        (env', tv1', eta') = optForAllCoBndr env sym tv1 eta
+        (env', tv1'', eta') = opt_forall tv1 eta
     in
-    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')
+    mk_forall tv1'' eta' (opt_univ co_or_dco opts env' sym prov' role ty1 ty2')
 
   | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1
   , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2
@@ -593,17 +680,22 @@ opt_univ env sym prov role oty1 oty2
   = let k1    = varType cv1
         k2    = varType cv2
         r'    = coVarRole cv1
-        eta   = mkUnivCo prov' Nominal k1 k2
-        eta_d = downgradeRole r' Nominal eta
+        eta   = case co_or_dco of
+                  Co  -> mk_univ Nominal k1 k2
+                  DCo -> snd $ mk_univ Nominal k1 k2
+        eta_d = downgradeRole r' Nominal $
+                case co_or_dco of
+                  Co  -> eta
+                  DCo -> mkHydrateDCo Nominal k1 eta k2
           -- eta gets opt'ed soon, but not yet.
         n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`
                 (mkCoVarCo cv1) `mkTransCo`
                 (mkSelCo (SelTyCon 3 r') eta_d)
         ty2'  = substTyWithCoVars [cv2] [n_co] ty2
 
-        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta
+        (env', cv1', eta') = opt_forall cv1 eta
     in
-    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')
+    mk_forall cv1' eta' (opt_univ co_or_dco opts env' sym prov' role ty1 ty2')
 
   | otherwise
   = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1
@@ -611,87 +703,122 @@ opt_univ env sym prov role oty1 oty2
         (a, b) | sym       = (ty2, ty1)
                | otherwise = (ty1, ty2)
     in
-    mkUnivCo prov' role a b
+    mk_univ role a b
 
   where
+    mk_castTy :: Type -> Type -> co_or_dco -> Type -> Type
+    mk_castTy = case co_or_dco of
+      Co  -> \ ty _ co  _ -> CastTy ty co
+      DCo -> \ ty l dco r -> CastTy ty (mkHydrateDCo Nominal l dco r)
+    mk_univ :: Role -> Type -> Type -> OptRes co_or_dco
+    mk_univ = case co_or_dco of
+      Co  -> mkUnivCo  prov'
+      DCo -> \ _ l_ty r_ty -> (l_ty, mkUnivDCo prov' r_ty)
+    mk_forall :: TyCoVar -> co_or_dco -> OptRes co_or_dco -> OptRes co_or_dco
+    mk_forall cv eta = case co_or_dco of
+      Co  -> mkForAllCo cv eta
+      DCo -> \ (_,body) -> (mkTyVarTy cv, mkForAllDCo cv eta body)
+    opt_forall :: TyCoVar -> co_or_dco -> (LiftingContext,TyCoVar,co_or_dco)
+    opt_forall tv co = case co_or_dco of
+      Co  -> optForAllCoBndr  opts env sym tv co
+      DCo -> optForAllDCoBndr opts env sym tv co
+    prov' :: UnivCoProvenance co_or_dco
     prov' = case prov of
 #if __GLASGOW_HASKELL__ < 901
 -- This alt is redundant with the first match of the FunDef
-      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco
+      PhantomProv kco    -> PhantomProv
+                          $ wrap "univ_co phantom" (opt_co_or_dco co_or_dco oty1)
+                              opts env sym False Nominal kco
 #endif
-      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
-      PluginProv _       -> prov
-      CorePrepProv _     -> prov
+      ProofIrrelProv kco -> ProofIrrelProv
+                          $ wrap "univ_co proof_irrel" (opt_co_or_dco co_or_dco oty1)
+                              opts env sym False Nominal kco
+      PluginProv str     -> PluginProv str
+      CorePrepProv homo  -> CorePrepProv homo
 
 -------------
-opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transList is = zipWithEqual "opt_transList" (opt_trans is)
+opt_transList :: HasDebugCallStack => OptCoParams -> InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList opts is = zipWithEqual "opt_transList" (opt_trans opts is)
   -- The input lists must have identical length.
 
-opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
-opt_trans is co1 co2
+opt_trans :: OptCoParams -> InScopeSet -> NormalCo -> NormalCo -> NormalCo
+opt_trans opts is co1 co2
   | isReflCo co1 = co2
     -- optimize when co1 is a Refl Co
-  | otherwise    = opt_trans1 is co1 co2
+  | otherwise    = opt_trans1 opts is co1 co2
 
-opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo
+opt_trans1 :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo
 -- First arg is not the identity
-opt_trans1 is co1 co2
+opt_trans1 opts is co1 co2
   | isReflCo co2 = co1
     -- optimize when co2 is a Refl Co
-  | otherwise    = opt_trans2 is co1 co2
+  | otherwise    = opt_trans2 opts is co1 co2
 
-opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo
+opt_trans2 :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo
 -- Neither arg is the identity
-opt_trans2 is (TransCo co1a co1b) co2
+opt_trans2 opts is (TransCo co1a co1b) co2
     -- Don't know whether the sub-coercions are the identity
-  = opt_trans is co1a (opt_trans is co1b co2)
+  = opt_trans opts is co1a (opt_trans opts is co1b co2)
 
-opt_trans2 is co1 co2
-  | Just co <- opt_trans_rule is co1 co2
+opt_trans2 opts is co1 co2
+  | Just co <- opt_trans_rule opts is co1 co2
   = co
 
-opt_trans2 is co1 (TransCo co2a co2b)
-  | Just co1_2a <- opt_trans_rule is co1 co2a
+opt_trans2 opts is co1 (TransCo co2a co2b)
+  | Just co1_2a <- opt_trans_rule opts is co1 co2a
   = if isReflCo co1_2a
     then co2b
-    else opt_trans1 is co1_2a co2b
+    else opt_trans1 opts is co1_2a co2b
 
-opt_trans2 _ co1 co2
+opt_trans2 _ _ co1 co2
   = mkTransCo co1 co2
 
 ------
+
 -- Optimize coercions with a top-level use of transitivity.
-opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+opt_trans_rule :: OptCoParams -> InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+
+-- Handle a composition of two directed coercions.
+opt_trans_rule opts is (HydrateDCo r lty1 dco1 _) (HydrateDCo _ lty2 dco2 rhs2)
+  = ( \ dco -> mkHydrateDCo r lty1 dco rhs2 )
+  <$> opt_trans_rule_dco opts is r lty1 dco1 lty2 dco2
 
-opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))
+opt_trans_rule opts is (SymCo (HydrateDCo r lty1 dco1 rhs1)) (SymCo (HydrateDCo _ lty2 dco2 _))
+  = ( \ dco -> mkSymCo $ mkHydrateDCo r lty2 dco rhs1 )
+  <$> opt_trans_rule_dco opts is r lty2 dco2 lty1 dco1
+
+-- When composing a Coercion with a DCoercion, we could imagine hydrating the DCoercion
+-- a single step (e.g. using 'hydrateOneLayerDCo') to expose cancellation opportunities.
+-- We don't do that for now.
+
+opt_trans_rule opts 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)
+    mkGReflRightCo r1 t1 (opt_trans opts is co1 co2)
 
 -- Push transitivity through matching destructors
-opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)
+opt_trans_rule opts is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)
   | d1 == d2
   , coercionRole co1 == coercionRole co2
   , co1 `compatible_co` co2
   = fireTransRule "PushNth" in_co1 in_co2 $
-    mkSelCo d1 (opt_trans is co1 co2)
+    mkSelCo d1 (opt_trans opts is co1 co2)
 
-opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
+opt_trans_rule opts is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
   | d1 == d2
   , co1 `compatible_co` co2
   = fireTransRule "PushLR" in_co1 in_co2 $
-    mkLRCo d1 (opt_trans is co1 co2)
+    mkLRCo d1 (opt_trans opts is co1 co2)
 
 -- Push transitivity inside instantiation
-opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+opt_trans_rule opts is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
   | ty1 `eqCoercion` ty2
   , co1 `compatible_co` co2
   = fireTransRule "TrPushInst" in_co1 in_co2 $
-    mkInstCo (opt_trans is co1 co2) ty1
+    mkInstCo (opt_trans opts is co1 co2) ty1
 
-opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
-                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)
+opt_trans_rule opts is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
+                       in_co2@(UnivCo p2 r2 _tyl2 tyr2)
   | Just prov' <- opt_trans_prov p1 p2
   = assert (r1 == r2) $
     fireTransRule "UnivCo" in_co1 in_co2 $
@@ -699,54 +826,56 @@ opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
   where
     -- if the provenances are different, opt'ing will be very confusing
     opt_trans_prov (PhantomProv kco1)    (PhantomProv kco2)
-      = Just $ PhantomProv $ opt_trans is kco1 kco2
+      = Just $ PhantomProv $ opt_trans opts is kco1 kco2
     opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
-      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2
-    opt_trans_prov (PluginProv str1)     (PluginProv str2)     | str1 == str2 = Just p1
+      = Just $ ProofIrrelProv $ opt_trans opts is kco1 kco2
+    opt_trans_prov (PluginProv str1)     (PluginProv str2)
+      | str1 == str2
+      = Just p1
     opt_trans_prov _ _ = Nothing
 
 -- Push transitivity down through matching top-level constructors.
-opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)
+opt_trans_rule opts is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)
   | tc1 == tc2
   = assert (r1 == r2) $
     fireTransRule "PushTyConApp" in_co1 in_co2 $
-    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)
+    mkTyConAppCo r1 tc1 (opt_transList opts is cos1 cos2)
 
-opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)
-                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)
+opt_trans_rule opts is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)
+                       in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)
   = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case
     assert (afr1 == afl2) $
     fireTransRule "PushFun" in_co1 in_co2 $
-    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)
-                          (opt_trans is co1a co2a)
-                          (opt_trans is co1b co2b)
+    mkFunCo2 r1 afl1 afr2 (opt_trans opts is w1 w2)
+                          (opt_trans opts is co1a co2a)
+                          (opt_trans opts is co1b co2b)
 
-opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+opt_trans_rule opts is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
   -- Must call opt_trans_rule_app; see Note [EtaAppCo]
-  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]
+  = opt_trans_rule_app opts is in_co1 in_co2 co1a [co1b] co2a [co2b]
 
 -- Eta rules
-opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
+opt_trans_rule opts is co1@(TyConAppCo r tc cos1) co2
   | Just cos2 <- etaTyConAppCo_maybe tc co2
   = fireTransRule "EtaCompL" co1 co2 $
-    mkTyConAppCo r tc (opt_transList is cos1 cos2)
+    mkTyConAppCo r tc (opt_transList opts is cos1 cos2)
 
-opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
+opt_trans_rule opts is co1 co2@(TyConAppCo r tc cos2)
   | Just cos1 <- etaTyConAppCo_maybe tc co1
   = fireTransRule "EtaCompR" co1 co2 $
-    mkTyConAppCo r tc (opt_transList is cos1 cos2)
+    mkTyConAppCo r tc (opt_transList opts is cos1 cos2)
 
-opt_trans_rule is co1@(AppCo co1a co1b) co2
+opt_trans_rule opts is co1@(AppCo co1a co1b) co2
   | Just (co2a,co2b) <- etaAppCo_maybe co2
-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
+  = opt_trans_rule_app opts is co1 co2 co1a [co1b] co2a [co2b]
 
-opt_trans_rule is co1 co2@(AppCo co2a co2b)
+opt_trans_rule opts is co1 co2@(AppCo co2a co2b)
   | Just (co1a,co1b) <- etaAppCo_maybe co1
-  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
+  = opt_trans_rule_app opts is co1 co2 co1a [co1b] co2a [co2b]
 
 -- Push transitivity inside forall
 -- forall over types.
-opt_trans_rule is co1 co2
+opt_trans_rule opts is co1 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
@@ -763,14 +892,14 @@ opt_trans_rule is co1 co2
     -- 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')
+      mkForAllCo tv1 (opt_trans opts is eta1 eta2) (opt_trans opts is' r1 r2')
     where
       is' = is `extendInScopeSet` tv1
       r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2
 
 -- Push transitivity inside forall
 -- forall over coercions.
-opt_trans_rule is co1 co2
+opt_trans_rule opts 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
@@ -789,7 +918,7 @@ opt_trans_rule is co1 co2
     --   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')
+      mkForAllCo cv1 (opt_trans opts is eta1 eta2) (opt_trans opts is' r1 r2')
     where
       is'  = is `extendInScopeSet` cv1
       role = coVarRole cv1
@@ -801,7 +930,7 @@ opt_trans_rule is co1 co2
                     r2
 
 -- Push transitivity inside axioms
-opt_trans_rule is co1 co2
+opt_trans_rule opts is co1 co2
 
   -- See Note [Push transitivity inside axioms] and
   -- Note [Push transitivity inside newtype axioms only]
@@ -810,34 +939,34 @@ opt_trans_rule is co1 co2
   , isNewTyCon (coAxiomTyCon con)
   , True <- sym
   , Just cos2 <- matchAxiom sym con ind co2
-  , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)
+  , let newAxInst = AxiomInstCo con ind (opt_transList opts is (map mkSymCo cos2) cos1)
   = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst
 
-  -- TrPushAxR
+  -- TrPushAxR (AxSuckR)
   | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
   , isNewTyCon (coAxiomTyCon con)
   , False <- sym
   , Just cos2 <- matchAxiom sym con ind co2
-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
+  , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos1 cos2)
   = fireTransRule "TrPushAxR" co1 co2 newAxInst
 
-  -- TrPushSymAxL
+  -- TrPushSymAxL (SymAxSuckL)
   | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
   , isNewTyCon (coAxiomTyCon con)
   , True <- sym
   , Just cos1 <- matchAxiom (not sym) con ind co1
-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))
+  , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos2 (map mkSymCo cos1))
   = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst
 
-  -- TrPushAxL
+  -- TrPushAxL (AxSuckL)
   | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
   , isNewTyCon (coAxiomTyCon con)
   , False <- sym
   , Just cos1 <- matchAxiom (not sym) con ind co1
-  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
+  , let newAxInst = AxiomInstCo con ind (opt_transList opts is cos1 cos2)
   = fireTransRule "TrPushAxL" co1 co2 newAxInst
 
-  -- TrPushAxSym/TrPushSymAx
+  -- TrPushAxSym/TrPushSymAx (AxSym/SymAx)
   | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
   , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
   , con1 == con2
@@ -851,16 +980,16 @@ opt_trans_rule is co1 co2
   , all (`elemVarSet` pivot_tvs) qtvs
   = fireTransRule "TrPushAxSym" co1 co2 $
     if sym2
-       -- TrPushAxSym
-    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs
-       -- TrPushSymAx
-    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs
+       -- TrPushAxSym (AxSym)
+    then liftCoSubstWith role qtvs (opt_transList opts is cos1 (map mkSymCo cos2)) lhs
+       -- TrPushSymAx (SymAx)
+    else liftCoSubstWith role qtvs (opt_transList opts is (map mkSymCo cos1) cos2) rhs
   where
     co1_is_axiom_maybe = isAxiom_maybe co1
     co2_is_axiom_maybe = isAxiom_maybe co2
     role = coercionRole co1 -- should be the same as coercionRole co2!
 
-opt_trans_rule _ co1 co2        -- Identity rule
+opt_trans_rule _ _ co1 co2        -- Identity rule
   | let ty1 = coercionLKind co1
         r   = coercionRole co1
         ty2 = coercionRKind co2
@@ -868,10 +997,11 @@ opt_trans_rule _ co1 co2        -- Identity rule
   = fireTransRule "RedTypeDirRefl" co1 co2 $
     mkReflCo r ty2
 
-opt_trans_rule _ _ _ = Nothing
+opt_trans_rule _ _ _ _ = Nothing
 
 -- See Note [EtaAppCo]
-opt_trans_rule_app :: InScopeSet
+opt_trans_rule_app :: OptCoParams
+                   -> InScopeSet
                    -> Coercion   -- original left-hand coercion (printing only)
                    -> Coercion   -- original right-hand coercion (printing only)
                    -> Coercion   -- left-hand coercion "function"
@@ -879,14 +1009,14 @@ opt_trans_rule_app :: InScopeSet
                    -> 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
+opt_trans_rule_app opts 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)
+  = opt_trans_rule_app opts 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)
+  = opt_trans_rule_app opts is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
 
   | otherwise
   = assert (co1bs `equalLength` co2bs) $
@@ -907,12 +1037,224 @@ opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
         co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs
         co2bs'' = zipWith mkTransCo co2bs' co2bs
     in
-    mkAppCos (opt_trans is co1a co2a')
-             (zipWith (opt_trans is) co1bs co2bs'')
+    mkAppCos (opt_trans opts is co1a co2a')
+             (zipWith (opt_trans opts is) co1bs co2bs'')
 
 fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
 fireTransRule _rule _co1 _co2 res
-  = Just res
+  = -- pprTrace _rule
+    --  (vcat [ text "co1:" <+> ppr _co1
+    --        , text "co2:" <+> ppr _co2
+    --        , text "res:" <+> ppr res ]) $
+    Just res
+
+------
+-- Optimize directed coercions
+
+-- N.B.: The reason we return (Type, DCoercion) and not just DCoercion is that we
+-- sometimes need the substituted LHS type (see opt_trans_dco).
+
+opt_phantom_dco :: OptCoParams -> LiftingContext -> Role -> Type -> DCoercion -> (Type, NormalDCo)
+opt_phantom_dco opts env r l_ty dco = opt_univ DCo opts env False (PhantomProv kco) Phantom l_ty r_ty
+  where
+    kco = DehydrateCo (mkKindCo $ mkHydrateDCo r l_ty dco r_ty)
+    r_ty = followDCo r l_ty dco
+    -- A naive attempt at removing this entirely causes issues in test "type_in_type_hole_fits".
+
+opt_dco4_wrap :: String -> OptCoParams -> LiftingContext -> ReprFlag -> Role -> Type -> DCoercion -> (Type, NormalDCo)
+opt_dco4_wrap str opts lc rep r l_ty dco = wrap ("opt_dco4 " ++ str) go opts lc False rep r dco
+  where
+    go opts lc _sym repr r dco = opt_dco4 opts lc repr r l_ty dco
+
+opt_dco2 :: OptCoParams
+         -> LiftingContext
+         -> Role   -- ^ The role of the input coercion
+         -> Type
+         -> DCoercion -> (Type, NormalDCo)
+opt_dco2 opts env Phantom ty dco = opt_phantom_dco opts env Phantom ty dco
+opt_dco2 opts env r       ty dco = opt_dco3 opts env Nothing r ty dco
+
+opt_dco3 :: OptCoParams -> LiftingContext -> Maybe Role -> Role -> Type -> DCoercion -> (Type, NormalDCo)
+opt_dco3 opts env (Just Phantom)          r ty dco = opt_phantom_dco opts env r ty dco
+opt_dco3 opts env (Just Representational) r ty dco = opt_dco4_wrap "opt_dco3 R" opts env True  r ty dco
+opt_dco3 opts env _                       r ty dco = opt_dco4_wrap "opt_dco3 _" opts env False r ty dco
+
+opt_dco4 :: OptCoParams -> LiftingContext -> ReprFlag -> Role -> Type -> DCoercion -> (Type, NormalDCo)
+opt_dco4 opts env rep r l_ty dco = case dco of
+
+    ReflDCo
+      -> lifted_dco
+    GReflRightDCo kco
+      | isGReflCo kco || isGReflCo kco'
+      -> lifted_dco
+      | otherwise
+      -> (l_ty', mkGReflRightDCo kco')
+      where
+        kco' = opt_co4 opts env False False Nominal kco
+    GReflLeftDCo kco
+      | isGReflCo kco || isGReflCo kco'
+      -> lifted_dco
+      | otherwise
+      -> (l_ty', mkGReflLeftDCo kco')
+      where
+        kco' = opt_co4 opts env False False Nominal kco
+
+    TyConAppDCo dcos
+      | Just (tc, l_tys) <- splitTyConApp_maybe l_ty
+      -> let
+            (arg_ltys, arg_dcos) =
+              case (rep, r) of
+                (True, Nominal) ->
+                  unzip $
+                  zipWith3
+                    (\ mb_r' -> opt_dco3 opts env mb_r' Nominal)
+                    (map Just (tyConRoleListRepresentational tc))
+                    l_tys
+                    dcos
+                (False, Nominal) ->
+                  unzip $
+                  zipWith (opt_dco4 opts env False Nominal) l_tys dcos
+                (_, Representational) ->
+                  unzip $
+                  zipWith3
+                    (opt_dco2 opts env)
+                    (tyConRoleListRepresentational tc)
+                    l_tys
+                    dcos
+                (_, Phantom) -> pprPanic "opt_dco4 sees a phantom!" (ppr dco)
+         in (mkTyConApp tc arg_ltys, mkTyConAppDCo arg_dcos)
+
+      | otherwise
+      -> pprPanic "opt_dco4: TyConAppDCo where ty is not a TyConApp" $
+          vcat [ text "dco =" <+> ppr dco
+               , text "l_ty =" <+> ppr l_ty ]
+
+    AppDCo dco1 dco2
+      | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty
+      , let
+          (l_ty1', l_dco1) = opt_dco4 opts env rep   r       l_ty1 dco1
+          (l_ty2', l_dco2) = opt_dco4 opts env False Nominal l_ty2 dco2
+      -> (mkAppTy l_ty1' l_ty2', mkAppDCo l_dco1 l_dco2)
+      | otherwise
+      -> pprPanic "opt_dco4: AppDCo where ty is not an AppTy" $
+           vcat [ text "dco =" <+> ppr dco
+                , text "l_ty =" <+> ppr l_ty ]
+
+    ForAllDCo dco_tcv k_dco body_dco
+      | ForAllTy (Bndr ty_tv af) body_ty <- coreFullView l_ty
+      ->  case optForAllDCoBndr opts env False dco_tcv k_dco of
+            (env', dco_tcv', k_dco') ->
+              -- SLD TODO: can this be simplified? I made too many mistakes writing this...
+              let body_ty' = substTyWithInScope (lcInScopeSet env') [ty_tv] [mkTyVarTy dco_tcv'] body_ty
+                  (body_ty'', body_dco') = opt_dco4_wrap "ForAllDCo" opts env' rep r body_ty' body_dco
+                  forall_ty = mkForAllTy (Bndr dco_tcv' af) body_ty''
+                  forall_dco = mkForAllDCo dco_tcv' k_dco' body_dco'
+                  forall_ty' = followDCo r forall_ty forall_dco
+              in (forall_ty, wrapRole_dco rep r forall_ty forall_dco forall_ty')
+      | otherwise
+      -> pprPanic "opt_dco4: ForAllDCo where ty is not a ForAllTy" $
+           vcat [ text "dco =" <+> ppr dco
+                , text "l_ty =" <+> ppr l_ty ]
+
+    CoVarDCo cv
+      -> let co' = opt_co4 opts env False rep r (CoVarCo cv)
+         in (coercionLKind co', mkDehydrateCo co')
+
+    AxiomInstDCo {}
+      -> (l_ty', rep_dco)
+    StepsDCo {}
+      -> (l_ty', rep_dco)
+
+    UnivDCo prov rhs_ty
+      -> opt_univ DCo opts env False prov r' l_ty rhs_ty
+
+    TransDCo dco1 dco2 ->
+      let
+        (l_ty', dco1') = opt_dco4 opts env rep r l_ty dco1
+
+        -- Follow the original directed coercion,
+        -- to avoid applying the substitution twice.
+        mid_ty = followDCo r l_ty dco1
+        (mid_ty', dco2') = opt_dco4 opts env rep r mid_ty dco2
+      in
+        (l_ty', opt_trans_dco opts (lcInScopeSet env) r' l_ty' dco1' mid_ty' dco2')
+
+    SubDCo dco ->
+      assert (r == Representational) $
+        opt_dco4_wrap "SubDCo" opts env True Nominal l_ty dco
+
+    DehydrateCo co ->
+      let co' = opt_co4_wrap "DehydrateCo" opts env False rep r co
+      in (coercionLKind co', mkDehydrateCo co')
+
+  where
+    lifted_dco = let lifted_co = liftCoSubst r' env l_ty
+                 in ( coercionLKind lifted_co, mkDehydrateCo lifted_co )
+    l_ty'      = substTyUnchecked (lcSubstLeft env) l_ty
+    r'         = chooseRole rep r
+    rep_dco    = wrapRole_dco rep r l_ty' dco (followDCo r l_ty' dco)
+
+---------------------------------------------------------
+-- Transitivity for directed coercions.
+
+opt_trans_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalDCo -> Type -> NormalDCo -> NormalDCo
+opt_trans_dco opts is r l_ty dco1 mid_ty dco2
+  | isReflDCo dco1 = dco2
+    -- optimize when dco1 is a Refl DCo
+  | otherwise    = opt_trans1_dco opts is r l_ty dco1 mid_ty dco2
+
+opt_trans1_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalDCo -> NormalDCo
+-- First arg is not the identity
+opt_trans1_dco opts is r l_ty dco1 mid_ty dco2
+  | isReflDCo dco2 = dco1
+    -- optimize when co2 is a Refl Co
+  | otherwise      = opt_trans2_dco opts is r l_ty dco1 mid_ty dco2
+
+opt_trans2_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalNonIdDCo -> NormalDCo
+-- Neither arg is the identity
+opt_trans2_dco opts  is r l_ty (TransDCo dco1a dco1b) mid_ty dco2
+    -- Don't know whether the sub-coercions are the identity
+  = let inner_ty = followDCo r l_ty dco1a
+    in opt_trans_dco opts is r l_ty dco1a inner_ty
+         (opt_trans_dco opts is r inner_ty dco1b mid_ty dco2)
+
+
+opt_trans2_dco opts is r l_ty dco1 mid_ty dco2
+  | Just co <- opt_trans_rule_dco opts is r l_ty dco1 mid_ty dco2
+  = co
+
+opt_trans2_dco opts is r l_ty dco1 mid_ty (TransDCo dco2a dco2b)
+  | Just dco1_2a <- opt_trans_rule_dco opts is r l_ty dco1 mid_ty dco2a
+  = if isReflDCo dco1_2a
+    then dco2b
+    else
+      let inner_ty = followDCo r mid_ty dco1_2a
+      in opt_trans1_dco opts is r mid_ty dco1_2a inner_ty dco2b
+
+opt_trans2_dco _ _ _ _ dco1 _ dco2
+  = mkTransDCo dco1 dco2
+
+opt_trans_rule_dco :: OptCoParams -> InScopeSet -> Role -> Type -> NormalNonIdDCo -> Type -> NormalNonIdDCo -> Maybe NormalDCo
+
+-- Handle undirected coercions.
+opt_trans_rule_dco opts is _ _ (DehydrateCo co1) _ (DehydrateCo co2)
+  = DehydrateCo <$> opt_trans_rule opts is co1 co2
+
+opt_trans_rule_dco _ _ r l_ty dco1 mid_ty dco2
+  | let r_ty = followDCo r mid_ty dco2
+  , l_ty `eqType` r_ty
+  = fireTransRule_dco "RedTypeDirRefl" dco1 dco2 $
+    mkReflDCo
+
+opt_trans_rule_dco _ _ _ _ _ _ _ = Nothing
+
+fireTransRule_dco :: String -> DCoercion -> DCoercion -> DCoercion -> Maybe DCoercion
+fireTransRule_dco _rule _dco1 _dco2 res
+  = --pprTrace _rule
+    -- (vcat [ text "dco1:" <+> ppr _dco1
+    --       , text "dco2:" <+> ppr _dco2
+    --       , text "res:" <+> ppr res ]) $
+    Just res
 
 {-
 Note [Push transitivity inside axioms]
@@ -1092,12 +1434,21 @@ wrapSym sym co | sym       = mkSymCo co
                | otherwise = co
 
 -- | Conditionally set a role to be representational
-wrapRole :: ReprFlag
+wrapRole :: HasDebugCallStack
+         => ReprFlag
          -> Role         -- ^ current role
          -> Coercion -> Coercion
 wrapRole False _       = id
 wrapRole True  current = downgradeRole Representational current
 
+wrapRole_dco :: HasDebugCallStack
+             => ReprFlag
+             -> Role         -- ^ current role
+             -> Type -> DCoercion -> Type
+             -> DCoercion
+wrapRole_dco False _       _    dco _    = dco
+wrapRole_dco True  current l_ty dco r_ty = downgradeDCoToRepresentational current l_ty dco r_ty
+
 -- | If we require a representational role, return that. Otherwise,
 -- return the "default" role provided.
 chooseRole :: ReprFlag
@@ -1112,6 +1463,7 @@ isAxiom_maybe (SymCo co)
   | Just (sym, con, ind, cos) <- isAxiom_maybe co
   = Just (not sym, con, ind, cos)
 isAxiom_maybe (AxiomInstCo con ind cos)
+  | isNewTyCon (coAxiomTyCon con) -- Adam Gundry's special sauce
   = Just (False, con, ind, cos)
 isAxiom_maybe _ = Nothing
 
@@ -1294,7 +1646,19 @@ and these two imply
 
 -}
 
-optForAllCoBndr :: LiftingContext -> Bool
+optForAllCoBndr :: OptCoParams
+                -> LiftingContext -> Bool
                 -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)
-optForAllCoBndr env sym
-  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env
+optForAllCoBndr opts env sym
+  = substForAllCoBndrUsingLC sym
+      (substTyUnchecked (lcSubstLeft env))
+      (opt_co4_wrap "optForAllCoBndr" opts env sym False Nominal) env
+
+optForAllDCoBndr :: OptCoParams
+                 -> LiftingContext -> Bool
+                 -> TyCoVar -> DCoercion -> (LiftingContext, TyCoVar, DCoercion)
+optForAllDCoBndr opts env sym tv
+  = substForAllDCoBndrUsingLC sym
+      (substTyUnchecked (lcSubstLeft env))
+      (snd . opt_dco4_wrap "optForAllDCoBndr" opts env False Nominal (tyVarKind tv)) env
+      tv
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index bddd6d89de..3219ef887c 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -394,7 +394,8 @@ orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 })
                                       `unionNameSet` orphNamesOfCo co2
 orphNamesOfCo (CoVarCo _)           = emptyNameSet
 orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
-orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1
+orphNamesOfCo (HydrateDCo _ t1 dco _) = orphNamesOfType t1 `unionNameSet` orphNamesOfDCo dco
+orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv orphNamesOfCo p `unionNameSet` orphNamesOfType t1
                                       `unionNameSet` orphNamesOfType t2
 orphNamesOfCo (SymCo co)            = orphNamesOfCo co
 orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
@@ -406,15 +407,33 @@ orphNamesOfCo (SubCo co)            = orphNamesOfCo co
 orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs
 orphNamesOfCo (HoleCo _)            = emptyNameSet
 
-orphNamesOfProv :: UnivCoProvenance -> NameSet
-orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co
-orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
-orphNamesOfProv (PluginProv _)      = emptyNameSet
-orphNamesOfProv (CorePrepProv _)    = emptyNameSet
+orphNamesOfDCo :: DCoercion -> NameSet
+orphNamesOfDCo ReflDCo                   = emptyNameSet
+orphNamesOfDCo (GReflRightDCo co)        = orphNamesOfCo co
+orphNamesOfDCo (GReflLeftDCo co)         = orphNamesOfCo co
+orphNamesOfDCo (TyConAppDCo cos)         = orphNamesOfDCos cos
+orphNamesOfDCo (AppDCo co1 co2)          = orphNamesOfDCo co1 `unionNameSet` orphNamesOfDCo co2
+orphNamesOfDCo (ForAllDCo _ kind_dco co) = orphNamesOfDCo kind_dco `unionNameSet` orphNamesOfDCo co
+orphNamesOfDCo (CoVarDCo _)              = emptyNameSet
+orphNamesOfDCo (AxiomInstDCo con)        = orphNamesOfCoCon con
+orphNamesOfDCo StepsDCo{}                = emptyNameSet
+orphNamesOfDCo (TransDCo co1 co2)        = orphNamesOfDCo co1 `unionNameSet` orphNamesOfDCo co2
+orphNamesOfDCo (DehydrateCo co)          = orphNamesOfCo co
+orphNamesOfDCo (UnivDCo p rhs)           = orphNamesOfProv orphNamesOfDCo p `unionNameSet` orphNamesOfType rhs
+orphNamesOfDCo (SubDCo dco)              = orphNamesOfDCo dco
+
+orphNamesOfProv :: (co -> NameSet) -> UnivCoProvenance co -> NameSet
+orphNamesOfProv orph_names (PhantomProv co)    = orph_names co
+orphNamesOfProv orph_names (ProofIrrelProv co) = orph_names co
+orphNamesOfProv _          (PluginProv _)      = emptyNameSet
+orphNamesOfProv _          (CorePrepProv _)    = emptyNameSet
 
 orphNamesOfCos :: [Coercion] -> NameSet
 orphNamesOfCos = orphNamesOfThings orphNamesOfCo
 
+orphNamesOfDCos :: [DCoercion] -> NameSet
+orphNamesOfDCos = orphNamesOfThings orphNamesOfDCo
+
 orphNamesOfCoCon :: CoAxiom br -> NameSet
 orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
   = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 0a0389d71b..1d8b05c99d 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
 
 -- (c) The University of Glasgow 2006
 --
@@ -24,7 +23,7 @@ module GHC.Core.FamInstEnv (
         FamInstMatch(..),
         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,
 
-        isDominatedBy, apartnessCheck, compatibleBranches,
+        isDominatedBy, apartnessCheck, compatibleBranches, chooseBranch,
 
         -- Injectivity
         InjectivityCheckResult(..),
@@ -33,7 +32,7 @@ module GHC.Core.FamInstEnv (
         -- Normalisation
         topNormaliseType, topNormaliseType_maybe,
         normaliseType, normaliseTcApp,
-        topReduceTyFamApp_maybe, reduceTyFamApp_maybe
+        topReduceTyFamApp_maybe, reduceTyFamApp_maybe,
     ) where
 
 import GHC.Prelude
@@ -1152,18 +1151,17 @@ The lookupFamInstEnv function does a nice job for *open* type families,
 but we also need to handle closed ones when normalising a type:
 -}
 
-reduceTyFamApp_maybe :: FamInstEnvs
-                     -> Role              -- Desired role of result coercion
-                     -> TyCon -> [Type]
-                     -> Maybe Reduction
--- Attempt to do a *one-step* reduction of a type-family application
+-- | Attempt to do a *one-step* reduction of a type-family application
 --    but *not* newtypes
 -- Works on type-synonym families always; data-families only if
 --     the role we seek is representational
 -- It does *not* normalise the type arguments first, so this may not
 --     go as far as you want. If you want normalised type arguments,
 --     use topReduceTyFamApp_maybe
---
+reduceTyFamApp_maybe :: FamInstEnvs
+                     -> Role              -- Desired role of result coercion
+                     -> TyCon -> [Type]
+                     -> Maybe Reduction
 -- The TyCon can be oversaturated.
 -- Works on both open and closed families
 --
@@ -1186,18 +1184,18 @@ reduceTyFamApp_maybe envs role tc tys
       -- NB: Allow multiple matches because of compatible overlap
 
   = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos
-    in Just $ coercionRedn co
+    in Just $ mkDehydrateCoercionRedn co
 
   | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
   , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys
   = let co = mkAxInstCo role ax ind inst_tys inst_cos
-    in Just $ coercionRedn co
+    in Just $ mkDehydrateCoercionRedn co
 
-  | Just ax           <- isBuiltInSynFamTyCon_maybe tc
-  , Just (coax,ts,ty) <- sfMatchFam ax tys
+  | Just ax          <- isBuiltInSynFamTyCon_maybe tc
+  , Just (coax,ts,_) <- sfMatchFam ax tys
   , role == coaxrRole coax
   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)
-    in Just $ mkReduction co ty
+    in Just $ mkDehydrateCoercionRedn co
 
   | otherwise
   = Nothing
@@ -1351,21 +1349,20 @@ topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction
 -- Always operates homogeneously: the returned type has the same kind as the
 -- original type, and the returned coercion is always homogeneous.
 topNormaliseType_maybe env ty
-  = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty
-       ; let hredn = mkHetReduction (mkReduction co nty) mkind_co
-       ; return $ homogeniseHetRedn Representational hredn }
+  = do { ((dco, mkind_co), nty) <- topNormaliseTypeX stepper combine ty
+       ; return $ homogeniseRedn (mkReduction dco nty) mkind_co }
   where
     stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper
 
-    combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2)
+    combine (c1, mdc1) (c2, mdc2) = (c1 `mkTransDCo` c2, mdc1 `mkTransMCo` mdc2)
 
-    unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)
+    unwrapNewTypeStepper' :: NormaliseStepper (DCoercion, MCoercionN)
     unwrapNewTypeStepper' rec_nts tc tys
-      = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys
+      = (\ co -> (mkDehydrateCo co, MRefl)) <$> unwrapNewTypeStepper rec_nts tc tys
 
       -- second coercion below is the kind coercion relating the original type's kind
       -- to the normalised type's kind
-    tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)
+    tyFamStepper :: NormaliseStepper (DCoercion, MCoercionN)
     tyFamStepper rec_nts tc tys  -- Try to step a type/data family
       = case topReduceTyFamApp_maybe env tc tys of
           Just (HetReduction (Reduction co rhs) res_co)
@@ -1385,13 +1382,13 @@ topReduceTyFamApp_maybe envs fam_tc arg_tys
   , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys
   = Just $
       mkHetReduction
-        (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn)
+        (mkTyConAppRedn fam_tc args_redns `mkTransRedn` redn)
         res_co
   | otherwise
   = Nothing
   where
     role = Representational
-    ArgsReductions (Reductions args_cos ntys) res_co
+    ArgsReductions args_redns@(Reductions _ ntys) res_co
       = initNormM envs role (tyCoVarsOfTypes arg_tys)
       $ normalise_tc_args fam_tc arg_tys
 
@@ -1427,16 +1424,16 @@ normalise_tc_app tc tys
   = -- A type-family application
     do { env <- getEnv
        ; role <- getRole
-       ; ArgsReductions redns@(Reductions args_cos ntys) res_co <- normalise_tc_args tc tys
+       ; ArgsReductions redns@(Reductions _ ntys) res_co <- normalise_tc_args tc tys
        ; case reduceTyFamApp_maybe env role tc ntys of
            Just redn1
              -> do { redn2 <- normalise_reduction redn1
-                   ; let redn3 = mkTyConAppCo role tc args_cos `mkTransRedn` redn2
-                   ; return $ assemble_result role redn3 res_co }
+                   ; let redn3 = mkTyConAppRedn tc redns `mkTransRedn` redn2
+                   ; return $ homogeniseRedn redn3 res_co }
            _ -> -- No unique matching family instance exists;
                 -- we do not do anything
                 return $
-                  assemble_result role (mkTyConAppRedn role tc redns) res_co }
+                  homogeniseRedn (mkTyConAppRedn tc redns) res_co }
 
   | otherwise
   = -- A synonym with no type families in the RHS; or data type etc
@@ -1444,16 +1441,10 @@ normalise_tc_app tc tys
     do { ArgsReductions redns res_co <- normalise_tc_args tc tys
        ; role <- getRole
        ; return $
-            assemble_result role (mkTyConAppRedn role tc redns) res_co }
-
-  where
-    assemble_result :: Role       -- r, ambient role in NormM monad
-                    -> Reduction  -- orig_ty ~r nty, possibly heterogeneous (nty possibly of changed kind)
-                    -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)
-                    -> Reduction  -- orig_ty ~r nty_casted
-                                  -- where nty_casted has same kind as orig_ty
-    assemble_result r redn kind_co
-      = mkCoherenceRightMRedn r redn (mkSymMCo kind_co)
+           homogeniseRedn (mkTyConAppRedn_MightBeSynonym role tc tys redns) res_co }
+             -- NB: we assume "tys" satisfy the hydration invariant from
+             -- Note [Following a directed coercion] in GHC.Core.Coercion,
+             -- because the "normalise" functions all only deal with fully zonked types.
 
 normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions
 normalise_tc_args tc tys
@@ -1475,16 +1466,17 @@ normalise_type ty
     go :: Type -> NormM Reduction
     go (TyConApp tc tys) = normalise_tc_app tc tys
     go ty@(LitTy {})
-      = do { r <- getRole
-           ; return $ mkReflRedn r ty }
+      = return $ mkReflRedn ty
     go (AppTy ty1 ty2) = go_app_tys ty1 [ty2]
 
     go (FunTy { ft_af = vis, ft_mult = w, ft_arg = ty1, ft_res = ty2 })
       = do { arg_redn <- go ty1
            ; res_redn <- go ty2
            ; w_redn <- withRole Nominal $ go w
-           ; r <- getRole
-           ; return $ mkFunRedn r vis w_redn arg_redn res_redn }
+           ; return $ mkFunRedn vis w_redn mkReflDCo mkReflDCo arg_redn res_redn
+              -- NB: normalise_type is homogeneous, so we can use ReflDCo
+              -- for the kind coercions.
+           }
     go (ForAllTy (Bndr tcvar vis) ty)
       = do { (lc', tv', k_redn) <- normalise_var_bndr tcvar
            ; redn <- withLC lc' $ normalise_type ty
@@ -1494,15 +1486,14 @@ normalise_type ty
       = do { redn <- go ty
            ; lc <- getLC
            ; let co' = substRightCo lc co
-           ; return $ mkCastRedn2 Nominal ty co redn co'
+           ; return $ mkCastRedn2 co redn co'
              --       ^^^^^^^^^^^ uses castCoercionKind2
            }
     go (CoercionTy co)
       = do { lc <- getLC
-           ; r <- getRole
            ; let kco = liftCoSubst Nominal lc (coercionType co)
                  co' = substRightCo lc co
-           ; return $ mkProofIrrelRedn r kco co co' }
+           ; return $ mkProofIrrelRedn co (mkDehydrateCo kco) co' }
 
     go_app_tys :: Type   -- function
                -> [Type] -- args
@@ -1510,7 +1501,7 @@ normalise_type ty
     -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args
     go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)
     go_app_tys fun_ty arg_tys
-      = do { fun_redn@(Reduction fun_co nfun) <- go fun_ty
+      = do { fun_redn@(Reduction _ nfun) <- go fun_ty
            ; case tcSplitTyConApp_maybe nfun of
                Just (tc, xis) ->
                  do { redn <- go (mkTyConApp tc (xis ++ arg_tys))
@@ -1518,15 +1509,14 @@ normalise_type ty
                    -- but that's a much more performance-sensitive function.
                    -- This type normalisation is not called in a loop.
                     ; return $
-                        mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransRedn` redn }
+                        mkAppRedns fun_redn (mkReflRedns arg_tys) `mkTransRedn` redn }
                Nothing ->
                  do { ArgsReductions redns res_co
                         <- normalise_args (typeKind nfun)
                                           (Inf.repeat Nominal)
                                           arg_tys
-                    ; role <- getRole
                     ; return $
-                        mkCoherenceRightMRedn role
+                        mkCoherenceRightMRedn
                           (mkAppRedns fun_redn redns)
                           (mkSymMCo res_co) } }
 
@@ -1542,7 +1532,7 @@ normalise_args :: Kind    -- of the function
 -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow
 normalise_args fun_ki roles args
   = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args
-       ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }
+       ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles args normed_args }
   where
     (ki_binders, inner_ki) = splitPiTys fun_ki
     fvs = tyCoVarsOfTypes args
@@ -1556,21 +1546,25 @@ normalise_tyvar tv
     do { lc <- getLC
        ; r  <- getRole
        ; return $ case liftCoSubstTyVar lc r tv of
-           Just co -> coercionRedn co
-           Nothing -> mkReflRedn r (mkTyVarTy tv) }
+           Just co -> mkDehydrateCoercionRedn co
+           Nothing -> mkReflRedn (mkTyVarTy tv) }
 
 normalise_reduction :: Reduction -> NormM Reduction
-normalise_reduction (Reduction co ty)
+normalise_reduction redn@(Reduction _ ty)
   = do { redn' <- normalise_type ty
-       ; return $ co `mkTransRedn` redn' }
+       ; return $ redn `mkTransRedn` redn' }
 
 normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Reduction)
 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 $ liftCoSubstVarBndrUsing reductionCoercion callback lc1 tcvar }
+       ; let
+           mk_co (lhs, redn)    = mkHydrateReductionDCoercion Nominal lhs redn
+           do_normalise ki      = do { redn <- normalise_type ki; return (ki, redn) }
+           callback lc ki       = runNormM (do_normalise ki) env lc Nominal
+           (lc, tcv, (_, redn)) = liftCoSubstVarBndrUsing mk_co callback lc1 tcvar
+       ; return (lc, tcv, redn) }
 
 -- | a monad for the normalisation functions, reading 'FamInstEnvs',
 -- a 'LiftingContext', and a 'Role'.
diff --git a/compiler/GHC/Core/FamInstEnv.hs-boot b/compiler/GHC/Core/FamInstEnv.hs-boot
new file mode 100644
index 0000000000..6679d4bae7
--- /dev/null
+++ b/compiler/GHC/Core/FamInstEnv.hs-boot
@@ -0,0 +1,9 @@
+module GHC.Core.FamInstEnv where
+
+import GHC.Core.Coercion.Axiom (CoAxiom, BranchIndex, Branched)
+import GHC.Core.TyCo.Rep (Coercion)
+import GHC.Core.Type (Type)
+import Data.Maybe (Maybe)
+
+chooseBranch :: CoAxiom Branched -> [Type]
+             -> Maybe (BranchIndex, [Type], [Coercion])
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 7bb1eb43aa..449774299b 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -1751,11 +1753,20 @@ lintValueType ty
              2 (text "has kind:" <+> ppr sk)
         ; return ty' }
 
+
+-------------------
 checkTyCon :: TyCon -> LintM ()
 checkTyCon tc
   = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
 
 -------------------
+checkTyCoVarInScope :: String -> Subst -> TyCoVar -> LintM ()
+checkTyCoVarInScope what subst tcv
+  = checkL (tcv `isInScope` subst) $
+    hang (text "The" <+> text what <+> text "variable" <+> pprBndr LetBind tcv)
+       2 (text "is out of scope")
+
+-------------------
 lintType :: Type -> LintM LintedType
 
 -- If you edit this function, you may need to update the GHC formalism
@@ -1772,12 +1783,9 @@ lintType (TyVarTy tv)
            -- In GHCi we may lint an expression with a free
            -- type variable.  Then it won't be in the
            -- substitution, but it should be in scope
-           Nothing | tv `isInScope` subst
-                   -> return (TyVarTy tv)
-                   | otherwise
-                   -> failWithL $
-                      hang (text "The type variable" <+> pprBndr LetBind tv)
-                         2 (text "is out of scope")
+           Nothing ->
+             do { checkTyCoVarInScope "type" subst tv
+                ; return (TyVarTy tv) }
      }
 
 lintType ty@(AppTy t1 t2)
@@ -2125,18 +2133,6 @@ which is what used to happen.   But that proved tricky and error prone
 (#17923), so now we return the coercion.
 -}
 
-
--- lints a coercion, confirming that its lh kind and its rh kind are both *
--- also ensures that the role is Nominal
-lintStarCoercion :: InCoercion -> LintM LintedCoercion
-lintStarCoercion g
-  = do { g' <- lintCoercion g
-       ; let Pair t1 t2 = coercionKind g'
-       ; checkValueType t1 (text "the kind of the left type in" <+> ppr g)
-       ; checkValueType t2 (text "the kind of the right type in" <+> ppr g)
-       ; lintRole g Nominal (coercionRole g)
-       ; return g' }
-
 lintCoercion :: InCoercion -> LintM LintedCoercion
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -2150,18 +2146,12 @@ lintCoercion (CoVarCo cv)
   = do { subst <- getSubst
        ; case lookupCoVar subst cv of
            Just linted_co -> return linted_co ;
-           Nothing
-              | cv `isInScope` subst
-                   -> return (CoVarCo cv)
-              | otherwise
-                   ->
-                      -- lintCoBndr always extends the substitution
-                      failWithL $
-                      hang (text "The coercion variable" <+> pprBndr LetBind cv)
-                         2 (text "is out of scope")
+           Nothing ->
+             -- lintCoBndr always extends the substitition
+             do { checkTyCoVarInScope "coercion" subst cv
+                ; return (CoVarCo cv) }
      }
 
-
 lintCoercion (Refl ty)
   = do { ty' <- lintType ty
        ; return (Refl ty') }
@@ -2229,7 +2219,13 @@ lintCoercion co@(ForAllCo tcv kind_co body_co)
        ; lintTyCoBndr tcv $ \tcv' ->
     do { body_co' <- lintCoercion body_co
        ; ensureEqTys (varType tcv') (coercionLKind kind_co') $
-         text "Kind mis-match in ForallCo" <+> ppr co
+         vcat [ text "Kind mis-match in ForallCo" <+> ppr co
+              , text "Type variable type:" <+> ppr (varType tcv')
+              , text " Coercion LHS type:" <+> ppr (coercionLKind kind_co')
+              , text "Type variable:" <+> ppr tcv
+              , text " Linted tyvar:" <+> ppr tcv'
+              , text "Kind coercion:" <+> ppr kind_co
+              , text "   Linted kco:" <+> ppr kind_co ]
 
        -- Assuming kind_co :: k1 ~ k2
        -- Need to check that
@@ -2278,13 +2274,27 @@ lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr
                               , text "arg_co:" <+> ppr co1
                               , text "res_co:" <+> ppr co2 ])
 
+lintCoercion (HydrateDCo r ty dco rty) =
+  do { ty'   <- lintType ty
+     ; rty'  <- lintType rty
+     ; co    <- lintDCoercion r ty' dco
+     ; let rty = coercionRKind co
+     ; ensureEqTys rty' rty $
+        vcat [ text "Mismatch of cached RHS type in HydrateDCo"
+             , text "dco:" <+> ppr dco
+             , text "stored RHS:" <+> ppr rty'
+             , text "computed RHS:" <+> ppr rty
+             , text "LHS:" <+> ppr ty
+             , text "role:" <+> ppr r ]
+     ; return co }
+
 -- See Note [Bad unsafe coercion]
-lintCoercion co@(UnivCo prov r ty1 ty2)
+lintCoercion (UnivCo prov r ty1 ty2)
   = do { ty1' <- lintType ty1
        ; ty2' <- lintType ty2
        ; let k1 = typeKind ty1'
              k2 = typeKind ty2'
-       ; prov' <- lint_prov k1 k2 prov
+       ; prov' <- lintProv Co r ty1' ty2' prov
 
        ; when (r /= Phantom && isTYPEorCONSTRAINT k1
                             && isTYPEorCONSTRAINT k2)
@@ -2343,27 +2353,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
                 _          -> return ()
             }
 
-     lint_prov k1 k2 (PhantomProv kco)
-       = do { kco' <- lintStarCoercion kco
-            ; lintRole co Phantom r
-            ; check_kinds kco' k1 k2
-            ; return (PhantomProv kco') }
-
-     lint_prov k1 k2 (ProofIrrelProv kco)
-       = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co)
-            ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co)
-            ; kco' <- lintStarCoercion kco
-            ; check_kinds kco k1 k2
-            ; return (ProofIrrelProv kco') }
-
-     lint_prov _ _ prov@(PluginProv _)   = return prov
-     lint_prov _ _ prov@(CorePrepProv _) = return prov
-
-     check_kinds kco k1 k2
-       = do { let Pair k1' k2' = coercionKind kco
-            ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)
-            ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }
-
 
 lintCoercion (SymCo co)
   = do { co' <- lintCoercion co
@@ -2530,6 +2519,206 @@ lintCoercion (HoleCo h)
   = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h
        ; lintCoercion (CoVarCo (coHoleCoVar h)) }
 
+lintDCoercion :: Role -> LintedType -> DCoercion -> LintM LintedCoercion
+lintDCoercion r l_ty dco = case dco of
+
+  CoVarDCo cv
+    | not (isCoVar cv)
+    -> failWithL (hang (text "Bad CoVarDCo:" <+> ppr cv)
+               2 (text "With offending type:" <+> ppr (varType cv)))
+    | otherwise
+    -> do { lintRole dco r (coVarRole cv)
+          ; cv_ty_l <- lintType $ coVarLType cv
+          ; ensureEqTys l_ty cv_ty_l
+              (hang (text "lintDCoercion: CoVarDCo LHS mis-match:" <+> ppr cv)
+                  2 (vcat [text "Expected type:" <+> ppr l_ty
+                          ,text "  Actual type:" <+> ppr cv_ty_l]))
+          ; subst <- getSubst
+          ; case lookupCoVar subst cv of
+              Just linted_co
+                -> return linted_co
+              Nothing
+                | cv `isInScope` subst
+                -> return (CoVarCo cv)
+                | otherwise
+                -> -- lintCoBndr always extends the substitition
+                  failWithL $
+                  hang (text "The coercion variable" <+> pprBndr LetBind cv)
+                     2 (text "is out of scope in this directed coercion")
+          }
+
+  ReflDCo ->
+    -- N.B.: the role might well not be Nominal.
+    return (mkReflCo r l_ty)
+
+  GReflRightDCo co ->
+    do { co' <- lintCoercion co
+       ; return (GRefl r l_ty (coToMCo co')) }
+
+  GReflLeftDCo co ->
+    do { sym_co' <- lintCoercion (mkSymCo co)
+       ; return (GRefl r l_ty (coToMCo sym_co')) }
+
+  SubDCo dco ->
+    do { lintRole dco Representational r
+       ; co <- lintDCoercion Nominal l_ty dco
+       ; return (SubCo co) }
+
+  TyConAppDCo dcos
+    | Just (tc, l_tys) <- splitTyConApp_maybe l_ty
+    -> do { checkTyCon tc
+          ; checkL (dcos `equalLength` l_tys) $
+             vcat [ text "mismatched number of arguments in TyConAppDCo"
+                  , text "args:" <+> ppr l_tys
+                  , text "dcos:" <+> ppr dcos ]
+          ; cos <- zipWith3M lintDCoercion (tyConRoleListX r tc) l_tys dcos
+          ; lintCoercion $ mkTyConAppCo r tc cos }
+    | otherwise
+    -> failWithL (text "TyConAppDCo where LHS type is not a TyCon:" <+> ppr l_ty)
+
+  AppDCo dco1 dco2
+{-  | TyConAppDCo {} <- dco1
+    -> failWithL (text "TyConAppDCo to the left of AppDCo:" <+> ppr dco)
+    | TyConApp {} <- l_ty
+    , isReflDCo dco1
+    -> failWithL (text "ReflDCo (TyConApp ...) to the left of AppDCo:" <+> ppr dco)
+-}
+    | Just (l_ty1, l_ty2) <- splitAppTy_maybe l_ty
+    -> do { co1' <- lintDCoercion r l_ty1 dco1
+          ; let
+              r2
+                | Phantom <- r
+                = Phantom
+                | otherwise
+                = Nominal
+          ; co2' <- lintDCoercion r2 l_ty2 dco2
+          ; return (mkAppCo co1' co2') }
+    | otherwise
+    -> failWithL (text "AppDCo where type is not an AppTy:" <+> ppr l_ty)
+
+  ForAllDCo tcv kco body_dco
+    | not (isTyCoVar tcv)
+    -> failWithL (text "Non tyco binder in ForAllDCo:" <+> ppr dco)
+    | otherwise
+    -> do { let l_ki = tyVarKind tcv
+          ; kco' <- lintStarDCoercion Nominal l_ki kco
+          ; lintTyCoBndr tcv $ \tcv' ->
+              case splitForAllTyCoVar_maybe l_ty of
+                Nothing -> failWithL (text "ForAllDCo where LHS type is not a ForAllTy: " <+> ppr l_ty <+> ppr dco)
+                Just (tcv'', body_ty) ->
+                  do { in_scope <- getInScope
+                       -- AMG TODO: is there a cleaner way of doing this?
+                     ; let body_ty' = substTyWithInScope in_scope [tcv''] [mkTyVarTy tcv'] body_ty
+                     ; lintForAllBody tcv' body_ty'
+                     ; body_co <- lintDCoercion r body_ty' body_dco
+                     ; let rhs_ty = coercionRKind body_co
+                     ; lintForAllBody tcv' rhs_ty -- AMG TODO: check anything else about rhs_ty?
+                     ; let co' = ForAllCo tcv' kco' body_co
+                     -- AMG TODO: if CoVar, check occurs only in Refl/GRefl?
+                     ; pure co'
+                     } }
+
+  AxiomInstDCo ax ->
+    do { (co, _ty) <- expandAxiomInstDCo (\ prop msg v -> lintL prop msg *> v) failWithL
+                       r l_ty ax
+       ; return co }
+
+  StepsDCo 0
+    -> return (mkReflCo r l_ty)
+  StepsDCo n ->
+    do { (co, ty) <- expandOneStepDCo (\ prop msg v -> lintL prop msg *> v) failWithL
+                        r l_ty
+       ; co' <- lintDCoercion r ty (StepsDCo (n-1))
+       ; lintCoercion $ co `mkTransCo` co' }
+
+  UnivDCo prov r_ty ->
+    do { r_ty' <- lintType r_ty
+       ; prov' <- lintProv DCo r l_ty r_ty prov
+       ; return (UnivCo prov' r l_ty r_ty') }
+
+  TransDCo dco1 dco2 ->
+    do { co1' <- lintDCoercion r l_ty dco1
+       ; let mid_ty = coercionRKind co1'
+       ; co2' <- lintDCoercion r mid_ty dco2
+       ; return (TransCo co1' co2') }
+
+  DehydrateCo co ->
+    do { co' <- lintCoercion co
+       ; let co_ty_l = coercionLKind co'
+             co_r    = coercionRole co'
+
+       ; checkL (r == co_r) $
+           hang (text "lintDCoercion: DehydrateCo role mismatch:" <+> ppr co)
+              2 (vcat [text "Expected role:" <+> ppr r
+                      ,text "  Actual role:" <+> ppr co_r])
+       ; ensureEqTys l_ty co_ty_l
+               (hang (text "lintDCoercion: DehydrateCo LHS mis-match:" <+> ppr co)
+                   2 (vcat [text "Expected type:" <+> ppr l_ty
+                           ,text "  Actual type:" <+> ppr co_ty_l]))
+       ; return co' }
+
+-- | Lint the provenance of a universal coercion (or directed coercion).
+lintProv :: forall co
+         .  CoOrDCo co
+         -> Role
+         -> LintedType
+         -> LintedType
+         -> UnivCoProvenance co
+         -> LintM (UnivCoProvenance LintedCoercion)
+lintProv co_or_dco r ty1 ty2 prov = case prov of
+  PhantomProv kco ->
+    do { kco' <- lint_star kco
+       ; lintRole prov Phantom r
+       ; check_kinds kco'
+       ; return (PhantomProv kco') }
+
+  ProofIrrelProv kco ->
+    do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 prov)
+       ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 prov)
+       ; kco' <- lint_star kco
+       ; check_kinds kco'
+       ; return (ProofIrrelProv kco') }
+
+  PluginProv str ->
+    return $ PluginProv str
+  CorePrepProv homo ->
+    return $ CorePrepProv homo
+
+  where
+    k1, k2 :: LintedKind
+    k1 = typeKind ty1
+    k2 = typeKind ty2
+
+    lint_star :: co -> LintM LintedCoercion
+    lint_star
+      = case co_or_dco of
+          Co  -> lintStarCoercion
+          DCo -> lintStarDCoercion r k1
+
+    check_kinds :: Coercion -> LintM ()
+    check_kinds kco
+      = do { let Pair k1' k2' = coercionKind kco
+           ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  prov)
+           ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight prov) }
+
+-- | Lints a kind coercion, confirming that its LHS kind and its RHS kind are both
+-- @Type@, and ensures that its role is 'Nominal'.
+lintStarCoercion :: InCoercion -> LintM LintedCoercion
+lintStarCoercion g = checkStarCoercion (coercionRole g) =<< lintCoercion g
+
+-- | Like 'lintStarCoercion' but for a directed coercion.
+lintStarDCoercion :: Role -> LintedKind -> DCoercion -> LintM LintedCoercion
+lintStarDCoercion r l_ki g = checkStarCoercion r =<< lintDCoercion Nominal l_ki g
+
+-- | Performs the checks required by 'lintStarCoercion'/'lintStarDCoercion',
+-- after the kind coercion has been linted on its own.
+checkStarCoercion :: Role -> Coercion -> LintM LintedCoercion
+checkStarCoercion r g
+  = do { lintRole g Nominal r
+       ; let Pair k1 k2 = coercionKind g
+       ; checkValueType k1 (text "the kind of the left type in" <+> ppr g)
+       ; checkValueType k2 (text "the kind of the right type in" <+> ppr g)
+       ; return g }
 
 {-
 Note [Conflict checking with AxiomInstCo]
@@ -3313,13 +3502,14 @@ ensureSubMult actual_mult described_mult err_msg = do
       | otherwise = m `eqType` n
 
 lintRole :: Outputable thing
-          => thing     -- where the role appeared
-          -> Role      -- expected
-          -> Role      -- actual
-          -> LintM ()
+         => thing     -- where the role appeared
+         -> Role      -- expected
+         -> Role      -- actual
+         -> LintM ()
 lintRole co r1 r2
   = lintL (r1 == r2)
           (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>
+           text ": expected" <+> ppr r1 <> comma <+>
            text "got" <+> ppr r2 $$
            text "in" <+> ppr co)
 
@@ -3550,16 +3740,16 @@ mk_cast_err thing_str co_str pp_thing co from_ty thing_ty
     from_msg     = text "From-" <> co_msg
     enclosed_msg = text "enclosed" <+> text thing_str
 
-mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
-mkBadUnivCoMsg lr co
+mkBadUnivCoMsg :: LeftOrRight -> UnivCoProvenance co -> SDoc
+mkBadUnivCoMsg lr prov
   = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>
-    text "side of a UnivCo:" <+> ppr co
+    text "side of a UnivCo:" <+> ppr prov
 
-mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
-mkBadProofIrrelMsg ty co
+mkBadProofIrrelMsg :: Outputable prov => Type -> prov -> SDoc
+mkBadProofIrrelMsg ty prov
   = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")
        2 (vcat [ text "type:" <+> ppr ty
-               , text "co:" <+> ppr co ])
+               , text "prov:" <+> ppr prov ])
 
 mkBadTyVarMsg :: Var -> SDoc
 mkBadTyVarMsg tv
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 0761691f84..7e626bb374 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -199,7 +199,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
         runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs
 
     core_todo =
-     [
+       [
     -- We want to do the static argument transform before full laziness as it
     -- may expose extra opportunities to float things outwards. However, to fix
     -- up the output of the transformation we need at do at least one simplify
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 1ecfa632e1..794b33b1fa 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -3254,9 +3254,11 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
            -> SimplM (SimplEnv, OutExpr, OutId)
 -- Note [Improving seq]
 improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]
-  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
+  | let ty1 = idType case_bndr1
+  , Just redn@(Reduction _ ty2) <- topNormaliseType_maybe fam_envs ty1
   = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2
-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
+        ; let co   = mkHydrateReductionDCoercion Representational ty1 redn
+              rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }
 
diff --git a/compiler/GHC/Core/Reduction.hs b/compiler/GHC/Core/Reduction.hs
index a4f1df4f70..bfa2b09523 100644
--- a/compiler/GHC/Core/Reduction.hs
+++ b/compiler/GHC/Core/Reduction.hs
@@ -7,18 +7,21 @@ module GHC.Core.Reduction
      -- * Reductions
      Reduction(..), ReductionN, ReductionR, HetReduction(..),
      Reductions(..),
-     mkReduction, mkReductions, mkHetReduction, coercionRedn,
-     reductionOriginalType,
-     downgradeRedn, mkSubRedn,
+     mkReduction, mkReductions, mkHetReduction, mkDehydrateCoercionRedn,
+     mkHydrateReductionDCoercion,
+     mkSubRedn,
      mkTransRedn, mkCoherenceRightRedn, mkCoherenceRightMRedn,
      mkCastRedn1, mkCastRedn2,
      mkReflRedn, mkGReflRightRedn, mkGReflRightMRedn,
      mkGReflLeftRedn, mkGReflLeftMRedn,
      mkAppRedn, mkAppRedns, mkFunRedn,
      mkForAllRedn, mkHomoForAllRedn, mkTyConAppRedn, mkClassPredRedn,
+     mkTyConAppRedn_MightBeSynonym,
      mkProofIrrelRedn, mkReflCoRedn,
-     homogeniseHetRedn,
+     homogeniseHetRedn, homogeniseRedn,
      unzipRedns,
+     mkReflRedns,
+     mkReflDCos,
 
      -- * Rewriting type arguments
      ArgsReductions(..),
@@ -28,15 +31,14 @@ module GHC.Core.Reduction
 
 import GHC.Prelude
 
-import GHC.Core.Class      ( Class(classTyCon) )
+import GHC.Core.Class      ( Class(..) )
 import GHC.Core.Coercion
 import GHC.Core.Predicate  ( mkClassPred )
-import GHC.Core.TyCon      ( TyCon )
+import GHC.Core.TyCon
 import GHC.Core.Type
 
 import GHC.Data.Pair       ( Pair(Pair) )
 import GHC.Data.List.Infinite ( Infinite (..) )
-import qualified GHC.Data.List.Infinite as Inf
 
 import GHC.Types.Var       ( VarBndr(..), setTyVarKind )
 import GHC.Types.Var.Env   ( mkInScopeSet )
@@ -46,6 +48,8 @@ import GHC.Utils.Misc      ( HasDebugCallStack, equalLength )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic     ( assertPpr )
 
+import Data.List           ( zipWith4 )
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -55,170 +59,119 @@ import GHC.Utils.Panic     ( assertPpr )
 
 Note [The Reduction type]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-Many functions in the type-checker rewrite a type, using Given type equalitie
-or type-family reductions, and return a Reduction, which is just a pair of the
-coercion and the RHS type of the coercion:
-  data Reduction = Reduction Coercion !Type
+Many functions in the type-checker rewrite a type, using Given type equalities
+or type-family reductions, and return a Reduction:
+
+  data Reduction = Reduction DCoercion !Type
+
+When we rewrite ty at role r, producing Reduction dco xi, we guarantee that
+dco :: ty ~r xi, up to zonking.
+
+In particular, if ty is fully zonked, we can call followDCo, and we should have
+
+  followDCo r ty dco ~ xi (up to zonking)
 
-The order of the arguments to the constructor serves as a reminder
-of what the Type is.  In
-    Reduction co ty
-`ty` appears to the right of `co`, reminding us that we must have:
-    co :: unrewritten_ty ~ ty
+The order of the arguments to the constructor serves as a reminder:
+
+    ty ~rewrite~> Reduction dco xi
+
+the rewritten type appears on the right, reminding us that we must have:
+
+  dco :: ty ~r xi
 
 Example functions that use this datatype:
+
    GHC.Core.FamInstEnv.topNormaliseType_maybe
      :: FamInstEnvs -> Type -> Maybe Reduction
    GHC.Tc.Solver.Rewrite.rewrite
      :: CtEvidence -> TcType -> TcS Reduction
 
 Having Reduction as a data type, with a strict Type field, rather than using
-a pair (Coercion,Type) gives several advantages (see #20161)
+a tuple (with all fields lazy), gives several advantages (see #20161)
 * The strictness in Type improved performance in rewriting of type families
   (around 2.5% improvement in T9872),
 * Compared to the situation before, it gives improved consistency around
   orientation of rewritings, as a Reduction is always left-to-right
   (the coercion's RHS type is always the type stored in the 'Reduction').
   No more 'mkSymCo's needed to convert between left-to-right and right-to-left.
-
-One could imagine storing the LHS type of the coercion in the Reduction as well,
-but in fact `reductionOriginalType` is very seldom used, so it's not worth it.
 -}
 
 -- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@.
--- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@
--- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined
--- by the context. That is, the LHS type of the coercion is the original type
--- @ty_in@, while its RHS type is the rewritten type @ty_out@.
+-- The 'Reduction' includes:
+--
+--  - a directed coercion @dco@,
+--  - the rewritten type @ty_out@
 --
--- A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction',
--- which separately stores the kind coercion.
+-- such that @dco :: ty_in ~ ty_out@, where the role @r@ of the coercion
+-- is determined by the context.
 --
 -- See Note [The Reduction type].
 data Reduction =
   Reduction
-    { reductionCoercion    :: Coercion
-    , reductionReducedType :: !Type
+    { reductionDCoercion    :: DCoercion
+    , reductionReducedType  :: !Type
     }
--- N.B. the 'Coercion' field must be lazy: see for instance GHC.Tc.Solver.Rewrite.rewrite_tyvar2
--- which returns an error in the 'Coercion' field when dealing with a Derived constraint
--- (which is OK as this Coercion gets ignored later).
--- We might want to revisit the strictness once Deriveds are removed.
+-- NB: the DCoercion field is left lazy, as we might not have any need
+-- to look at it.
 
--- | Stores a heterogeneous reduction.
---
--- The stored kind coercion must relate the kinds of the
--- stored reduction. That is, in @HetReduction (Reduction co xi) kco@,
--- we must have:
---
--- >  co :: ty ~ xi
--- > kco :: typeKind ty ~ typeKind xi
-data HetReduction =
-  HetReduction
-    Reduction
-    MCoercionN
-  -- N.B. strictness annotations don't seem to make a difference here
-
--- | Create a heterogeneous reduction.
---
--- Pre-condition: the provided kind coercion (second argument)
--- relates the kinds of the stored reduction.
--- That is, if the coercion stored in the 'Reduction' is of the form
---
--- > co :: ty ~ xi
---
--- Then the kind coercion supplied must be of the form:
---
--- > kco :: typeKind ty ~ typeKind xi
-mkHetReduction :: Reduction  -- ^ heterogeneous reduction
-               -> MCoercionN -- ^ kind coercion
-               -> HetReduction
-mkHetReduction redn mco = HetReduction redn mco
-{-# INLINE mkHetReduction #-}
+-- | A 'Reduction' in which the 'Coercion' has 'Nominal' role.
+type ReductionN = Reduction
 
--- | Homogenise a heterogeneous reduction.
---
--- Given @HetReduction (Reduction co xi) kco@, with
---
--- >  co :: ty ~ xi
--- > kco :: typeKind(ty) ~ typeKind(xi)
---
--- this returns the homogeneous reduction:
---
--- > hco :: ty ~ ( xi |> sym kco )
-homogeniseHetRedn :: Role -> HetReduction -> Reduction
-homogeniseHetRedn role (HetReduction redn kco)
-  = mkCoherenceRightMRedn role redn (mkSymMCo kco)
-{-# INLINE homogeniseHetRedn #-}
+-- | A 'Reduction' in which the 'Coercion' has 'Representational' role.
+type ReductionR = Reduction
 
--- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type.
---
--- Pre-condition: the RHS type of the coercion matches the provided type
--- (perhaps up to zonking).
+-- | Create a 'Reduction' from a pair of a 'DCoercion' and a 'Type.
 --
--- Use 'coercionRedn' when you only have the coercion.
-mkReduction :: Coercion -> Type -> Reduction
-mkReduction co ty = Reduction co ty
+-- Use 'mkDehydrateCoercionRedn' when you only have a 'Coercion'.
+mkReduction :: DCoercion -> Type -> Reduction
+mkReduction co rty = Reduction co rty
 {-# INLINE mkReduction #-}
 
 instance Outputable Reduction where
   ppr redn =
     braces $ vcat
-      [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn)
-      , text " reductionReducedType:" <+> ppr (reductionReducedType redn)
-      , text "    reductionCoercion:" <+> ppr (reductionCoercion redn)
+      [ text " reductionReducedType:" <+> ppr (reductionReducedType redn)
+      , text "   reductionDCoercion:" <+> ppr (reductionDCoercion redn)
       ]
 
--- | A 'Reduction' in which the 'Coercion' has 'Nominal' role.
-type ReductionN = Reduction
+-- | Turn a 'Coercion' into a 'Reduction' by dehydrating.
+--
+-- Prefer using 'mkReduction' wherever possible to avoid doing these indirections.
+mkDehydrateCoercionRedn :: Coercion -> Reduction
+mkDehydrateCoercionRedn co =
+  Reduction (mkDehydrateCo co) (coercionRKind co)
+{-# INLINE mkDehydrateCoercionRedn #-}
 
--- | A 'Reduction' in which the 'Coercion' has 'Representational' role.
-type ReductionR = Reduction
+-- | Hydrate the 'DCoercion' stored inside a 'Reduction' into a full-fledged 'Coercion'.
+mkHydrateReductionDCoercion :: HasDebugCallStack
+                            => Role
+                            -> Type -- ^ LHS type (must not contain metavariables)
+                            -> Reduction
+                            -> Coercion
+mkHydrateReductionDCoercion r lty (Reduction dco rty) = mkHydrateDCo r lty dco rty
+{-# INLINE mkHydrateReductionDCoercion #-}
 
--- | Get the original, unreduced type corresponding to a 'Reduction'.
---
--- This is obtained by computing the LHS kind of the stored coercion,
--- which may be slow.
-reductionOriginalType :: Reduction -> Type
-reductionOriginalType = coercionLKind . reductionCoercion
-{-# INLINE reductionOriginalType #-}
-
--- | Turn a 'Coercion' into a 'Reduction'
--- by inspecting the RHS type of the coercion.
---
--- Prefer using 'mkReduction' when you already know
--- the RHS type of the coercion, to avoid computing it anew.
-coercionRedn :: Coercion -> Reduction
-coercionRedn co = Reduction co (coercionRKind co)
-{-# INLINE coercionRedn #-}
-
--- | Downgrade the role of the coercion stored in the 'Reduction'.
-downgradeRedn :: Role -- ^ desired role
-              -> Role -- ^ current role
-              -> Reduction
-              -> Reduction
-downgradeRedn new_role old_role redn@(Reduction co _)
-  = redn { reductionCoercion = downgradeRole new_role old_role co }
-{-# INLINE downgradeRedn #-}
-
--- | Downgrade the role of the coercion stored in the 'Reduction',
+-- | Downgrade the role of the directed coercion stored in the 'Reduction',
 -- from 'Nominal' to 'Representational'.
-mkSubRedn :: Reduction -> Reduction
-mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co }
+mkSubRedn :: HasDebugCallStack => Type -> Reduction -> Reduction
+mkSubRedn lhs redn@(Reduction dco rhs)
+  = redn { reductionDCoercion = mkSubDCo lhs dco rhs }
 {-# INLINE mkSubRedn #-}
 
--- | Compose a reduction with a coercion on the left.
+-- | Compose two reductions.
 --
--- Pre-condition: the provided coercion's RHS type must match the LHS type
--- of the coercion that is stored in the reduction.
-mkTransRedn :: Coercion -> Reduction -> Reduction
-mkTransRedn co1 redn@(Reduction co2 _)
-  = redn { reductionCoercion = co1 `mkTransCo` co2 }
+-- Assumes that forming a composite is valid, i.e. the RHS type of
+-- the first directed coercion equals, up to zonking,
+-- the LHS type of the second directed coercion.
+mkTransRedn :: Reduction -> Reduction -> Reduction
+mkTransRedn (Reduction dco1 _) (Reduction dco2 ty2)
+  = Reduction (dco1 `mkTransDCo` dco2) ty2
 {-# INLINE mkTransRedn #-}
 
 -- | The reflexive reduction.
-mkReflRedn :: Role -> Type -> Reduction
-mkReflRedn r ty = mkReduction (mkReflCo r ty) ty
+mkReflRedn :: Type -> Reduction
+mkReflRedn ty = mkReduction mkReflDCo ty
+{-# INLINE mkReflRedn #-}
 
 -- | Create a 'Reduction' from a kind cast, in which
 -- the casted type is the rewritten type.
@@ -226,10 +179,10 @@ mkReflRedn r ty = mkReduction (mkReflCo r ty) ty
 -- Given @ty :: k1@, @mco :: k1 ~ k2@,
 -- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@
 -- at the given 'Role'.
-mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction
-mkGReflRightRedn role ty co
+mkGReflRightRedn :: Type -> CoercionN -> Reduction
+mkGReflRightRedn ty co
   = mkReduction
-      (mkGReflRightCo role ty co)
+      (mkGReflRightDCo co)
       (mkCastTy ty co)
 {-# INLINE mkGReflRightRedn #-}
 
@@ -239,11 +192,13 @@ mkGReflRightRedn role ty co
 -- Given @ty :: k1@, @mco :: k1 ~ k2@,
 -- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@
 -- at the given 'Role'.
-mkGReflRightMRedn :: Role -> Type -> MCoercionN -> Reduction
-mkGReflRightMRedn role ty mco
+mkGReflRightMRedn :: Type -> MCoercionN -> Reduction
+mkGReflRightMRedn ty MRefl
+  = mkReflRedn ty
+mkGReflRightMRedn ty (MCo kco)
   = mkReduction
-      (mkGReflRightMCo role ty mco)
-      (mkCastTyMCo ty mco)
+      (mkGReflRightDCo kco)
+      (mkCastTy ty kco)
 {-# INLINE mkGReflRightMRedn #-}
 
 -- | Create a 'Reduction' from a kind cast, in which
@@ -252,10 +207,10 @@ mkGReflRightMRedn role ty mco
 -- Given @ty :: k1@, @mco :: k1 ~ k2@,
 -- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@
 -- at the given 'Role'.
-mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction
-mkGReflLeftRedn role ty co
+mkGReflLeftRedn :: Type -> CoercionN -> Reduction
+mkGReflLeftRedn ty co
   = mkReduction
-      (mkGReflLeftCo role ty co)
+      (mkGReflLeftDCo co)
       ty
 {-# INLINE mkGReflLeftRedn #-}
 
@@ -265,10 +220,12 @@ mkGReflLeftRedn role ty co
 -- Given @ty :: k1@, @mco :: k1 ~ k2@,
 -- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@
 -- at the given 'Role'.
-mkGReflLeftMRedn :: Role -> Type -> MCoercionN -> Reduction
-mkGReflLeftMRedn role ty mco
+mkGReflLeftMRedn :: Type -> MCoercionN -> Reduction
+mkGReflLeftMRedn ty MRefl
+  = mkReflRedn ty
+mkGReflLeftMRedn ty (MCo kco)
   = mkReduction
-      (mkGReflLeftMCo role ty mco)
+      (mkGReflLeftDCo kco)
       ty
 {-# INLINE mkGReflLeftMRedn #-}
 
@@ -278,10 +235,10 @@ mkGReflLeftMRedn role ty mco
 -- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@
 -- of the given 'Role' (which must match the role of the coercion stored
 -- in the 'Reduction' argument).
-mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction
-mkCoherenceRightRedn r (Reduction co1 ty2) kco
+mkCoherenceRightRedn :: Reduction -> CoercionN -> Reduction
+mkCoherenceRightRedn (Reduction co1 ty2) kco
   = mkReduction
-      (mkCoherenceRightCo r ty2 kco co1)
+      (mkCoherenceRightDCo kco co1)
       (mkCastTy ty2 kco)
 {-# INLINE mkCoherenceRightRedn #-}
 
@@ -291,11 +248,12 @@ mkCoherenceRightRedn r (Reduction co1 ty2) kco
 -- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@
 -- of the given 'Role' (which must match the role of the coercion stored
 -- in the 'Reduction' argument).
-mkCoherenceRightMRedn :: Role -> Reduction -> MCoercionN -> Reduction
-mkCoherenceRightMRedn r (Reduction co1 ty2) kco
+mkCoherenceRightMRedn :: Reduction -> MCoercionN -> Reduction
+mkCoherenceRightMRedn redn MRefl = redn
+mkCoherenceRightMRedn (Reduction co1 ty2) (MCo kco)
   = mkReduction
-      (mkCoherenceRightMCo r ty2 kco co1)
-      (mkCastTyMCo ty2 kco)
+      (mkCoherenceRightDCo kco co1)
+      (mkCastTy ty2 kco)
 {-# INLINE mkCoherenceRightMRedn #-}
 
 -- | Apply a cast to a 'Reduction', casting both the original and the reduced type.
@@ -307,16 +265,14 @@ mkCoherenceRightMRedn r (Reduction co1 ty2) kco
 --
 -- Pre-condition: the 'Type' passed in is the same as the LHS type
 -- of the coercion stored in the 'Reduction'.
-mkCastRedn1 :: Role
-            -> Type      -- ^ original type
-            -> CoercionN -- ^ coercion to cast with
-            -> Reduction -- ^ rewritten type, with rewriting coercion
+mkCastRedn1 :: CoercionN -- ^ coercion to cast with
+            -> Reduction  -- ^ rewritten type, with rewriting coercion
             -> Reduction
-mkCastRedn1 r ty cast_co (Reduction co xi)
+mkCastRedn1 cast_co (Reduction dco xi)
   -- co :: ty ~r ty'
   -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co)
   = mkReduction
-      (castCoercionKind1 co r ty xi cast_co)
+      (castDCoercionKind1 dco cast_co)
       (mkCastTy xi cast_co)
 {-# INLINE mkCastRedn1 #-}
 
@@ -327,15 +283,13 @@ mkCastRedn1 r ty cast_co (Reduction co xi)
 --
 -- Pre-condition: the 'Type' passed in is the same as the LHS type
 -- of the coercion stored in the 'Reduction'.
-mkCastRedn2 :: Role
-            -> Type      -- ^ original type
-            -> CoercionN -- ^ coercion to cast with on the left
+mkCastRedn2 :: CoercionN -- ^ coercion to cast with on the left
             -> Reduction -- ^ rewritten type, with rewriting coercion
             -> CoercionN -- ^ coercion to cast with on the right
             -> Reduction
-mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co'
+mkCastRedn2 cast_co (Reduction nco nty) cast_co'
   = mkReduction
-      (castCoercionKind2 nco r ty nty cast_co cast_co')
+      (castDCoercionKind2 nco cast_co cast_co')
       (mkCastTy nty cast_co')
 {-# INLINE mkCastRedn2 #-}
 
@@ -343,26 +297,31 @@ mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co'
 --
 -- Combines 'mkAppCo' and 'mkAppTy`.
 mkAppRedn :: Reduction -> Reduction -> Reduction
-mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2)
-  = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2)
+mkAppRedn (Reduction co1 rty1) (Reduction co2 rty2)
+  = mkReduction
+      (mkAppDCo co1 co2)
+      (mkAppTy rty1 rty2)
 {-# INLINE mkAppRedn #-}
 
 -- | Create a function 'Reduction'.
 --
 -- Combines 'mkFunCo' and 'mkFunTy'.
-mkFunRedn :: Role
-          -> FunTyFlag
+mkFunRedn :: FunTyFlag
           -> ReductionN -- ^ multiplicity reduction
+          -> DCoercionN -- ^ argument 'RuntimeRep' coercion
+          -> DCoercionN -- ^ result 'RuntimeRep' coercion
           -> Reduction  -- ^ argument reduction
           -> Reduction  -- ^ result reduction
           -> Reduction
-mkFunRedn r af
-  (Reduction w_co w_ty)
-  (Reduction arg_co arg_ty)
-  (Reduction res_co res_ty)
+mkFunRedn af
+  (Reduction w_co w_rty)
+  arg_repco
+  res_repco
+  (Reduction arg_co arg_rty)
+  (Reduction res_co res_rty)
     = mkReduction
-        (mkFunCo r af w_co arg_co res_co)
-        (mkFunTy   af w_ty arg_ty res_ty)
+        (mkFunDCo af w_co arg_repco res_repco arg_co res_co)
+        (mkFunTy af w_rty arg_rty res_rty)
 {-# INLINE mkFunRedn #-}
 
 -- | Create a 'Reduction' associated to a Π type,
@@ -374,48 +333,44 @@ mkForAllRedn :: ForAllTyFlag
              -> ReductionN -- ^ kind reduction
              -> Reduction  -- ^ body reduction
              -> Reduction
-mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)
+mkForAllRedn vis tv1 (Reduction h rki) (Reduction co rty)
   = mkReduction
-      (mkForAllCo tv1 h co)
-      (mkForAllTy (Bndr tv2 vis) ty)
+      (mkForAllDCo tv1 h co)
+      (mkForAllTy (Bndr tv2 vis) rty)
   where
-    tv2 = setTyVarKind tv1 ki'
+    tv2 = setTyVarKind tv1 rki
 {-# INLINE mkForAllRedn #-}
 
 -- | Create a 'Reduction' of a quantified type from a
 -- 'Reduction' of the body.
 --
 -- Combines 'mkHomoForAllCos' and 'mkForAllTys'.
-mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction
-mkHomoForAllRedn bndrs (Reduction co ty)
+mkHomoForAllRedn :: [TyVarBinder] -> Type -> Reduction -> Reduction
+mkHomoForAllRedn bndrs ty1 (Reduction co ty2)
   = mkReduction
-      (mkHomoForAllCos (binderVars bndrs) co)
-      (mkForAllTys bndrs ty)
+      (mkHomoForAllDCos (binderVars bndrs) (typeTypeOrConstraint ty1) co)
+      (mkForAllTys bndrs ty2)
 {-# INLINE mkHomoForAllRedn #-}
 
 -- | Create a 'Reduction' from a coercion between coercions.
 --
 -- Combines 'mkProofIrrelCo' and 'mkCoercionTy'.
-mkProofIrrelRedn :: Role      -- ^ role of the created coercion, "r"
-                 -> CoercionN -- ^ co :: phi1 ~N phi2
-                 -> Coercion  -- ^ g1 :: phi1
-                 -> Coercion  -- ^ g2 :: phi2
-                 -> Reduction -- ^ res_co :: g1 ~r g2
-mkProofIrrelRedn role co g1 g2
+mkProofIrrelRedn :: Coercion   -- ^ lhs_co
+                 -> DCoercionN -- ^ dco :: lhs_co ~ rhs_co
+                 -> Coercion   -- ^ rhs_co
+                 -> Reduction
+mkProofIrrelRedn _g1 co g2
   = mkReduction
-      (mkProofIrrelCo role co g1 g2)
-      (mkCoercionTy g2)
+      (mkProofIrrelDCo co rhs_co)
+      rhs_co
+  where
+    rhs_co = mkCoercionTy g2
 {-# INLINE mkProofIrrelRedn #-}
 
--- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion',
+-- | Create a reflexive 'Reduction' whose LHS and RHS is the given 'Coercion',
 -- with the specified 'Role'.
-mkReflCoRedn :: Role -> Coercion -> Reduction
-mkReflCoRedn role co
-  = mkReduction
-      (mkReflCo role co_ty)
-      co_ty
-  where
-    co_ty = mkCoercionTy co
+mkReflCoRedn :: Coercion -> Reduction
+mkReflCoRedn co = mkReduction mkReflDCo (mkCoercionTy co)
 {-# INLINE mkReflCoRedn #-}
 
 -- | A collection of 'Reduction's where the coercions and the types are stored separately.
@@ -425,36 +380,72 @@ mkReflCoRedn role co
 -- This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn',
 -- which expect separate types and coercions.
 --
--- Invariant: the two stored lists are of the same length,
--- and the RHS type of each coercion is the corresponding type.
-data Reductions = Reductions [Coercion] [Type]
+-- Invariant: given @Reductions lhs_tys dcos rhs_tys@, and an ambient role @r@,
+-- we can obtain the @rhs_tys@ by following the directed coercions starting from the repsective
+-- @lhs_tys@. Equivalently, @zipWith (followDCo r) lhs_tys dcos@ is equal (up to zonking) to @rhs_tys@.
+data Reductions = Reductions [DCoercion] [Type]
+
+instance Outputable Reductions where
+  ppr (Reductions dcos rtys) = parens (text "Reductions" <+> ppr dcos <+> ppr rtys)
 
 -- | Create 'Reductions' from individual lists of coercions and types.
 --
 -- The lists should be of the same length, and the RHS type of each coercion
 -- should match the specified type in the other list.
-mkReductions :: [Coercion] -> [Type] -> Reductions
-mkReductions cos tys = Reductions cos tys
+mkReductions :: [DCoercion] -> [Type] -> Reductions
+mkReductions cos tys2 = Reductions cos tys2
 {-# INLINE mkReductions #-}
 
+mkReflRedns :: [Type] -> Reductions
+mkReflRedns tys = mkReductions (mkReflDCos tys) tys
+{-# INLINE mkReflRedns #-}
+
+mkReflDCos :: [Type] -> [DCoercion]
+mkReflDCos tys = replicate (length tys) mkReflDCo
+{-# INLINE mkReflDCos #-}
+
 -- | Combines 'mkAppCos' and 'mkAppTys'.
 mkAppRedns :: Reduction -> Reductions -> Reduction
-mkAppRedns (Reduction co ty) (Reductions cos tys)
-  = mkReduction (mkAppCos co cos) (mkAppTys ty tys)
+mkAppRedns (Reduction co ty2) (Reductions cos tys2)
+  = mkReduction (mkAppDCos co cos) (mkAppTys ty2 tys2)
 {-# INLINE mkAppRedns #-}
 
 -- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`.
-mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction
-mkTyConAppRedn role tc (Reductions cos tys)
-  = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys)
+--
+-- Use this when you know the 'TyCon' is not a type synonym. If it might be,
+-- use 'mkTyConAppRedn_MightBeSynonym'.
+mkTyConAppRedn :: TyCon -> Reductions -> Reduction
+mkTyConAppRedn tc (Reductions cos tys2)
+  = mkReduction (mkTyConAppDCo cos) (mkTyConApp tc tys2)
 {-# INLINE mkTyConAppRedn #-}
 
+-- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`.
+--
+-- Use 'mkTyConAppRedn' if the 'TyCon' is definitely not a type synonym.
+mkTyConAppRedn_MightBeSynonym :: Role -> TyCon -> [Type] -> Reductions -> Reduction
+mkTyConAppRedn_MightBeSynonym role tc tys1 redns@(Reductions dcos tys2)
+  -- 'mkTyConAppCo' handles synomyms by using substitution lifting.
+  -- We don't have that for directed coercions, so we use hydrate/dehydrate
+  -- so that we can call 'liftCoSubst'.
+  -- In the future, it might be desirable to implement substitution lifting
+  -- for directed coercions to avoid this (and a similar issue in simplifyArgsWorker).
+  | ExpandsSyn tv_dco_prs rhs_ty leftover_dcos <- expandSynTyCon_maybe tc dcos
+  , let tv_co_prs = zipWith4 hydrate (tyConRoleListX role tc) tys1 tv_dco_prs tys2
+  = mkReduction
+      (mkAppDCos (mkDehydrateCo $ liftCoSubst role (mkLiftingContext tv_co_prs) rhs_ty) leftover_dcos)
+      (mkTyConApp tc tys2)
+  | otherwise = mkTyConAppRedn tc redns
+  where
+    hydrate r l (tv,dco) t = (tv, mkHydrateDCo r l dco t)
+    {-# INLINE hydrate #-}
+{-# INLINE mkTyConAppRedn_MightBeSynonym #-}
+
 -- | Reduce the arguments of a 'Class' 'TyCon'.
 mkClassPredRedn :: Class -> Reductions -> Reduction
-mkClassPredRedn cls (Reductions cos tys)
+mkClassPredRedn cls (Reductions cos tys2)
   = mkReduction
-      (mkTyConAppCo Nominal (classTyCon cls) cos)
-      (mkClassPred cls tys)
+      (mkTyConAppDCo cos)
+      (mkClassPred cls tys2)
 {-# INLINE mkClassPredRedn #-}
 
 -- | Obtain 'Reductions' from a list of 'Reduction's by unzipping.
@@ -471,7 +462,7 @@ unzipRedns = foldr accRedn (Reductions [] [])
 --
 --   unzipRedns <$> zipWithM f tys roles
 --
--- - GHC.Tc.Solver.Monad.breakTyEqCycle_maybe, with two calls of the form:
+-- - GHC.Tc.Solver.Monad.breakTyVarCycle_maybe, with two calls of the form:
 --
 --   unzipRedns <$> mapM f tys
 --
@@ -479,6 +470,67 @@ unzipRedns = foldr accRedn (Reductions [] [])
 -- but the above locations aren't performance critical, so it was deemed
 -- to not be worth it.
 
+-- | Stores a heterogeneous reduction.
+--
+-- The stored kind coercion must relate the kinds of the
+-- stored reduction. That is, in @HetReduction (Reduction co xi) kco@,
+-- we must have:
+--
+-- >  co :: ty ~ xi
+-- > kco :: typeKind ty ~ typeKind xi
+data HetReduction =
+  HetReduction
+    Reduction
+    MCoercionN
+  -- N.B. strictness annotations don't seem to make a difference here
+
+-- | Create a heterogeneous reduction.
+--
+-- Pre-condition: the provided kind coercion (second argument)
+-- relates the kinds of the stored reduction.
+-- That is, if the coercion stored in the 'Reduction' is of the form
+--
+-- > co :: ty ~ xi
+--
+-- Then the kind coercion supplied must be of the form:
+--
+-- > kco :: typeKind ty ~ typeKind xi
+mkHetReduction :: Reduction  -- ^ heterogeneous reduction
+               -> MCoercionN -- ^ kind coercion
+               -> HetReduction
+mkHetReduction redn mco = HetReduction redn mco
+{-# INLINE mkHetReduction #-}
+
+-- | Homogenise a heterogeneous reduction.
+--
+-- Given @HetReduction (Reduction co xi) kco@, with
+--
+-- >  co :: ty ~ xi
+-- > kco :: typeKind(ty) ~ typeKind(xi)
+--
+-- this returns the homogeneous reduction:
+--
+-- > hco :: ty ~ ( xi |> sym kco )
+homogeniseHetRedn :: HetReduction -> Reduction
+homogeniseHetRedn (HetReduction redn kco)
+  = mkCoherenceRightMRedn redn (mkSymMCo kco)
+{-# INLINE homogeniseHetRedn #-}
+
+-- | Homogenise a reduction.
+--
+-- Given @redn = Reduction co xi@ and kind coercion @kco@, with
+--
+-- >  co :: ty ~ xi
+-- > kco :: typeKind(ty) ~ typeKind(xi)
+--
+-- this returns the homogeneous reduction:
+--
+-- > hco :: ty ~ ( xi |> sym kco )
+homogeniseRedn :: Reduction -> MCoercionN -> Reduction
+homogeniseRedn redn mco
+  = mkCoherenceRightMRedn redn (mkSymMCo mco)
+{-# INLINE homogeniseRedn #-}
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -779,6 +831,9 @@ data ArgsReductions =
   -- The strictness annotations and UNPACK pragma here are crucial
   -- to getting good performance in simplifyArgsWorker's tight loop.
 
+instance Outputable ArgsReductions where
+  ppr (ArgsReductions redns kco) = parens (text "ArgsReductions" <+> ppr redns <+> ppr kco)
+
 -- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv.
 -- See Note [simplifyArgsWorker]
 {-# INLINE simplifyArgsWorker #-}
@@ -791,6 +846,7 @@ simplifyArgsWorker :: HasDebugCallStack
                        -- list of binders can be shorter or longer than the list of args
                    -> TyCoVarSet   -- free vars of the args
                    -> Infinite Role-- list of roles, r
+                   -> [Type]       -- original type arguments ty_i
                    -> [Reduction]  -- rewritten type arguments, arg_i
                                    -- each comes with the coercion used to rewrite it,
                                    -- arg_co_i :: ty_i ~ arg_i
@@ -804,10 +860,10 @@ simplifyArgsWorker :: HasDebugCallStack
 -- function is all about. That is, (f xi_1 ... xi_n), where xi_i are the returned arguments,
 -- *is* well kinded.
 simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
-                   orig_roles orig_simplified_args
+                   orig_roles tys redns
   = go orig_lc
        orig_ki_binders orig_inner_ki
-       orig_roles orig_simplified_args
+       orig_roles (zip tys redns)
   where
     orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs
 
@@ -815,7 +871,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
        -> [PiTyBinder]    -- Unsubsted binders of function's kind
        -> Kind            -- Unsubsted result kind of function (not a Pi-type)
        -> Infinite Role   -- Roles at which to rewrite these ...
-       -> [Reduction]     -- rewritten arguments, with their rewriting coercions
+       -> [(Type, Reduction)]   -- rewritten arguments, with their rewriting coercions
        -> ArgsReductions
     go !lc binders inner_ki _ []
         -- The !lc makes the function strict in the lifting context
@@ -828,7 +884,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
         kind_co | noFreeVarsOfType final_kind = MRefl
                 | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind
 
-    go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns)
+    go lc (binder:binders) inner_ki (Inf role roles) ((orig_ty,arg_redn):arg_redns)
       =  -- We rewrite an argument ty with arg_redn = Reduction arg_co arg
          -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),
          -- typeKind(ty) = typeKind(arg).
@@ -841,10 +897,11 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
          -- significantly in optimized builds; see #18502
          let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder)
              !(Reduction casted_co casted_xi)
-                      = mkCoherenceRightRedn role arg_redn kind_co
+                      = mkCoherenceRightRedn arg_redn kind_co
          -- now, extend the lifting context with the new binding
              !new_lc | Just tv <- namedPiTyBinder_maybe binder
-                     = extendLiftingContextAndInScope lc tv casted_co
+                     = extendLiftingContextAndInScope lc tv
+                     $ mkHydrateDCo role orig_ty casted_co casted_xi
                      | otherwise
                      = lc
              !(ArgsReductions (Reductions cos xis) final_kind_co)
@@ -854,14 +911,14 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
               final_kind_co
 
     -- See Note [Last case in simplifyArgsWorker]
-    go lc [] inner_ki roles arg_redns
+    go lc [] inner_ki roles arg_tys_and_redns
       = let co1 = liftCoSubst Nominal lc inner_ki
+            (orig_tys, arg_redns) = unzip arg_tys_and_redns
             co1_kind              = coercionKind co1
-            unrewritten_tys       = map reductionOriginalType arg_redns
-            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys
-            casted_args           = assertPpr (equalLength arg_redns arg_cos)
+            (arg_cos, res_co)     = decomposePiCos co1 co1_kind orig_tys
+            casted_redns          = assertPpr (equalLength arg_redns arg_cos)
                                               (ppr arg_redns $$ ppr arg_cos)
-                                  $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos
+                                  $ zipWith mkCoherenceRightRedn arg_redns arg_cos
                -- In general decomposePiCos can return fewer cos than tys,
                -- but not here; because we're well typed, there will be enough
                -- binders. Note that decomposePiCos does substitutions, so even
@@ -873,6 +930,6 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
             (bndrs, new_inner)    = splitPiTys rewritten_kind
 
             ArgsReductions redns_out res_co_out
-              = go zapped_lc bndrs new_inner roles casted_args
+              = go zapped_lc bndrs new_inner roles (zip orig_tys casted_redns)
         in
           ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index b751b10206..8d80a072a4 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -98,8 +98,9 @@ data SimpleOpts = SimpleOpts
 defaultSimpleOpts :: SimpleOpts
 defaultSimpleOpts = SimpleOpts
    { so_uf_opts = defaultUnfoldingOpts
-   , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
    , so_eta_red = False
+   , so_co_opts = OptCoercionOpts { optCoercionOpts = Nothing }
+         -- Nothing <=> no coercion optimisation
    }
 
 simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs
index aa9c04c46b..e81b711171 100644
--- a/compiler/GHC/Core/TyCo/FVs.hs
+++ b/compiler/GHC/Core/TyCo/FVs.hs
@@ -13,22 +13,28 @@ module GHC.Core.TyCo.FVs
         shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv,
 
         shallowTyCoVarsOfCo, shallowTyCoVarsOfCos,
+        shallowTyCoVarsOfDCo, shallowTyCoVarsOfDCos,
         tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo,
+        tyCoVarsOfDCo,
         coVarsOfType, coVarsOfTypes,
         coVarsOfCo, coVarsOfCos,
         tyCoVarsOfCoDSet,
         tyCoFVsOfCo, tyCoFVsOfCos,
         tyCoVarsOfCoList,
+        tyCoVarsOfDCoList,
 
         almostDevoidCoVarOfCo,
+        almostDevoidCoVarOfDCo,
 
         -- Injective free vars
         injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType,
         invisibleVarsOfType, invisibleVarsOfTypes,
 
         -- Any and No Free vars
-        anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,
-        noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,
+        anyFreeVarsOfType, anyFreeVarsOfTypes,
+        anyFreeVarsOfCo, anyFreeVarsOfDCo,
+        noFreeVarsOfType, noFreeVarsOfTypes,
+        noFreeVarsOfCo, noFreeVarsOfDCo,
 
         -- * Free type constructors
         tyConsOfType, tyConsOfTypes,
@@ -309,11 +315,15 @@ tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co
 tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
 tyCoVarsOfCos cos = runTyCoVars (deep_cos cos)
 
+tyCoVarsOfDCo :: DCoercion -> TyCoVarSet
+tyCoVarsOfDCo co = runTyCoVars (deep_dco co)
+
 deep_ty  :: Type       -> Endo TyCoVarSet
 deep_tys :: [Type]     -> Endo TyCoVarSet
 deep_co  :: Coercion   -> Endo TyCoVarSet
 deep_cos :: [Coercion] -> Endo TyCoVarSet
-(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet
+deep_dco :: DCoercion  -> Endo TyCoVarSet
+(deep_ty, deep_tys, deep_co, deep_cos, deep_dco, _) = foldTyCo deepTcvFolder emptyVarSet
 
 deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
 deepTcvFolder = TyCoFolder { tcf_view = noView
@@ -353,6 +363,12 @@ shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co)
 shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet
 shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos)
 
+shallowTyCoVarsOfDCo :: DCoercion -> TyCoVarSet
+shallowTyCoVarsOfDCo dco = runTyCoVars (shallow_dco dco)
+
+shallowTyCoVarsOfDCos :: [DCoercion] -> TyCoVarSet
+shallowTyCoVarsOfDCos dcos = runTyCoVars (shallow_dcos dcos)
+
 -- | Returns free variables of types, including kind variables as
 -- a non-deterministic set. For type synonyms it does /not/ expand the
 -- synonym.
@@ -371,7 +387,9 @@ shallow_ty  :: Type       -> Endo TyCoVarSet
 shallow_tys :: [Type]     -> Endo TyCoVarSet
 shallow_co  :: Coercion   -> Endo TyCoVarSet
 shallow_cos :: [Coercion] -> Endo TyCoVarSet
-(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet
+shallow_dco  :: DCoercion   -> Endo TyCoVarSet
+shallow_dcos :: [DCoercion] -> Endo TyCoVarSet
+(shallow_ty, shallow_tys, shallow_co, shallow_cos, shallow_dco, shallow_dcos) = foldTyCo shallowTcvFolder emptyVarSet
 
 shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
 shallowTcvFolder = TyCoFolder { tcf_view = noView
@@ -420,7 +438,7 @@ deep_cv_ty  :: Type       -> Endo CoVarSet
 deep_cv_tys :: [Type]     -> Endo CoVarSet
 deep_cv_co  :: Coercion   -> Endo CoVarSet
 deep_cv_cos :: [Coercion] -> Endo CoVarSet
-(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet
+(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos, _, _) = foldTyCo deepCoVarFolder emptyVarSet
 
 deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet)
 deepCoVarFolder = TyCoFolder { tcf_view = noView
@@ -617,6 +635,9 @@ tyCoVarsOfCoList :: Coercion -> [TyCoVar]
 -- See Note [Free variables of types]
 tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co
 
+tyCoVarsOfDCoList :: DCoercion -> [TyCoVar]
+tyCoVarsOfDCoList co = fvVarList $ tyCoFVsOfDCo co
+
 tyCoFVsOfMCo :: MCoercion -> FV
 tyCoFVsOfMCo MRefl    = emptyFV
 tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co
@@ -641,9 +662,12 @@ 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 (HydrateDCo _ t1 dco _) fv_cand in_scope acc
+  = (tyCoFVsOfType t1 `unionFV` tyCoFVsOfDCo dco) 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
+  = (tyCoFVsOfProv tyCoFVsOfCo p
+      `unionFV` tyCoFVsOfType t1
+      `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 (SelCo _ co)        fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
@@ -657,16 +681,35 @@ tyCoFVsOfCoVar :: CoVar -> FV
 tyCoFVsOfCoVar v fv_cand in_scope acc
   = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc
 
-tyCoFVsOfProv :: UnivCoProvenance -> FV
-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 (CorePrepProv _)    fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfProv :: (co -> FV) -> UnivCoProvenance co -> FV
+tyCoFVsOfProv tyCoFVs_of_co (PhantomProv co)    fv_cand in_scope acc = tyCoFVs_of_co co fv_cand in_scope acc
+tyCoFVsOfProv tyCoFVs_of_co (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVs_of_co co fv_cand in_scope acc
+tyCoFVsOfProv _             (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfProv _             (CorePrepProv _)    fv_cand in_scope acc = emptyFV fv_cand in_scope acc
 
 tyCoFVsOfCos :: [Coercion] -> FV
 tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc
 tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc
 
+tyCoFVsOfDCos :: [DCoercion] -> FV
+tyCoFVsOfDCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfDCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfDCo co `unionFV` tyCoFVsOfDCos cos) fv_cand in_scope acc
+
+tyCoFVsOfDCo :: DCoercion -> FV
+tyCoFVsOfDCo ReflDCo              fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfDCo (GReflRightDCo co)   fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
+tyCoFVsOfDCo (GReflLeftDCo  co)   fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
+tyCoFVsOfDCo (TyConAppDCo dcos)   fv_cand in_scope acc = tyCoFVsOfDCos dcos fv_cand in_scope acc
+tyCoFVsOfDCo (AppDCo dco1 dco2)   fv_cand in_scope acc = (tyCoFVsOfDCo dco1 `unionFV` tyCoFVsOfDCo dco2) fv_cand in_scope acc
+tyCoFVsOfDCo (ForAllDCo tv kind_dco co) fv_cand in_scope acc
+  = (tyCoFVsVarBndr tv (tyCoFVsOfDCo co) `unionFV` tyCoFVsOfDCo kind_dco) fv_cand in_scope acc
+tyCoFVsOfDCo (CoVarDCo v)         fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc
+tyCoFVsOfDCo AxiomInstDCo{}       fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfDCo StepsDCo{}           fv_cand in_scope acc = emptyFV fv_cand in_scope acc
+tyCoFVsOfDCo (TransDCo dco1 dco2) fv_cand in_scope acc = (tyCoFVsOfDCo dco1 `unionFV` tyCoFVsOfDCo dco2) fv_cand in_scope acc
+tyCoFVsOfDCo (DehydrateCo co)     fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc
+tyCoFVsOfDCo (UnivDCo p rhs)      fv_cand in_scope acc = (tyCoFVsOfProv tyCoFVsOfDCo p `unionFV` tyCoFVsOfType rhs) fv_cand in_scope acc
+tyCoFVsOfDCo (SubDCo dco)         fv_cand in_scope acc = tyCoFVsOfDCo dco fv_cand in_scope acc
 
 ----- Whether a covar is /Almost Devoid/ in a type or coercion ----
 
@@ -677,6 +720,10 @@ almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool
 almostDevoidCoVarOfCo cv co =
   almost_devoid_co_var_of_co co cv
 
+almostDevoidCoVarOfDCo :: CoVar -> DCoercion -> Bool
+almostDevoidCoVarOfDCo cv dco =
+  almost_devoid_co_var_of_dco dco cv
+
 almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool
 almost_devoid_co_var_of_co (Refl {}) _ = True   -- covar is allowed in Refl and
 almost_devoid_co_var_of_co (GRefl {}) _ = True  -- GRefl, so we don't look into
@@ -697,8 +744,11 @@ almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv
 almost_devoid_co_var_of_co (HoleCo h)  cv = (coHoleCoVar h) /= cv
 almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv
   = almost_devoid_co_var_of_cos cos cv
+almost_devoid_co_var_of_co (HydrateDCo _ t1 dco _) cv
+  = almost_devoid_co_var_of_type t1 cv
+  && almost_devoid_co_var_of_dco dco cv
 almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv
-  = almost_devoid_co_var_of_prov p cv
+  = almost_devoid_co_var_of_prov almost_devoid_co_var_of_co p cv
   && almost_devoid_co_var_of_type t1 cv
   && almost_devoid_co_var_of_type t2 cv
 almost_devoid_co_var_of_co (SymCo co) cv
@@ -726,13 +776,46 @@ almost_devoid_co_var_of_cos (co:cos) cv
   = almost_devoid_co_var_of_co co cv
   && almost_devoid_co_var_of_cos cos cv
 
-almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool
-almost_devoid_co_var_of_prov (PhantomProv co) cv
-  = almost_devoid_co_var_of_co co cv
-almost_devoid_co_var_of_prov (ProofIrrelProv co) cv
+almost_devoid_co_var_of_dcos :: [DCoercion] -> CoVar -> Bool
+almost_devoid_co_var_of_dcos [] _ = True
+almost_devoid_co_var_of_dcos (co:cos) cv
+  = almost_devoid_co_var_of_dco co cv
+  && almost_devoid_co_var_of_dcos cos cv
+
+almost_devoid_co_var_of_dco :: DCoercion -> CoVar -> Bool
+almost_devoid_co_var_of_dco ReflDCo _ = True
+almost_devoid_co_var_of_dco GReflRightDCo{} _ = True -- GRefl, so we don't look into
+                                                     -- the coercions
+almost_devoid_co_var_of_dco GReflLeftDCo{}  _ = True
+almost_devoid_co_var_of_dco (TyConAppDCo cos) cv
+  = almost_devoid_co_var_of_dcos cos cv
+almost_devoid_co_var_of_dco (AppDCo co arg) cv
+  = almost_devoid_co_var_of_dco co cv
+  && almost_devoid_co_var_of_dco arg cv
+almost_devoid_co_var_of_dco (ForAllDCo v kind_co co) cv
+  = almost_devoid_co_var_of_dco kind_co cv
+  && (v == cv || almost_devoid_co_var_of_dco co cv)
+almost_devoid_co_var_of_dco (CoVarDCo v) cv = v /= cv
+almost_devoid_co_var_of_dco AxiomInstDCo{} _ = True
+almost_devoid_co_var_of_dco StepsDCo{} _     = True
+almost_devoid_co_var_of_dco (TransDCo co1 co2) cv
+  = almost_devoid_co_var_of_dco co1 cv
+  && almost_devoid_co_var_of_dco co2 cv
+almost_devoid_co_var_of_dco (DehydrateCo co) cv
   = almost_devoid_co_var_of_co co cv
-almost_devoid_co_var_of_prov (PluginProv _)   _ = True
-almost_devoid_co_var_of_prov (CorePrepProv _) _ = True
+almost_devoid_co_var_of_dco (UnivDCo prov rhs) cv
+  = almost_devoid_co_var_of_prov almost_devoid_co_var_of_dco prov cv
+  && almost_devoid_co_var_of_type rhs cv
+almost_devoid_co_var_of_dco (SubDCo dco) cv
+  = almost_devoid_co_var_of_dco dco cv
+
+almost_devoid_co_var_of_prov :: (co -> CoVar -> Bool) -> UnivCoProvenance co -> CoVar -> Bool
+almost_devoid_co_var_of_prov almost_devoid_co (PhantomProv co) cv
+  = almost_devoid_co co cv
+almost_devoid_co_var_of_prov almost_devoid_co (ProofIrrelProv co) cv
+  = almost_devoid_co co cv
+almost_devoid_co_var_of_prov _ (PluginProv _)   _ = True
+almost_devoid_co_var_of_prov _ (CorePrepProv _) _ = True
 
 almost_devoid_co_var_of_type :: Type -> CoVar -> Bool
 almost_devoid_co_var_of_type (TyVarTy _) _ = True
@@ -953,27 +1036,35 @@ afvFolder check_fv = TyCoFolder { tcf_view = noView
 
 anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool
 anyFreeVarsOfType check_fv ty = DM.getAny (f ty)
-  where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+  where (f, _, _, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
 
 anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool
 anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys)
-  where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+  where (_, f, _, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
 
 anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool
 anyFreeVarsOfCo check_fv co = DM.getAny (f co)
-  where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+  where (_, _, f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet
+
+anyFreeVarsOfDCo :: (TyCoVar -> Bool) -> DCoercion -> Bool
+anyFreeVarsOfDCo check_fv co = DM.getAny (f co)
+  where (_, _, _, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet
 
 noFreeVarsOfType :: Type -> Bool
 noFreeVarsOfType ty = not $ DM.getAny (f ty)
-  where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
+  where (f, _, _, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 noFreeVarsOfTypes :: [Type] -> Bool
 noFreeVarsOfTypes tys = not $ DM.getAny (f tys)
-  where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
+  where (_, f, _, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 noFreeVarsOfCo :: Coercion -> Bool
 noFreeVarsOfCo co = not $ DM.getAny (f co)
-  where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet
+  where (_, _, f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet
+
+noFreeVarsOfDCo :: DCoercion -> Bool
+noFreeVarsOfDCo dco = not $ DM.getAny (f dco)
+  where (_, _, _, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet
 
 
 {- *********************************************************************
@@ -1113,7 +1204,8 @@ tyConsOfType ty
      go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
                                    = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r
      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 (UnivCo p _ t1 t2)      = go_prov go_co p `unionUniqSets` go t1 `unionUniqSets` go t2
+     go_co (HydrateDCo _ t1 dco _) = go t1 `unionUniqSets` go_dco dco
      go_co (CoVarCo {})            = emptyUniqSet
      go_co (HoleCo {})             = emptyUniqSet
      go_co (SymCo co)              = go_co co
@@ -1128,14 +1220,29 @@ tyConsOfType ty
      go_mco MRefl    = emptyUniqSet
      go_mco (MCo co) = go_co co
 
-     go_prov (PhantomProv co)    = go_co co
-     go_prov (ProofIrrelProv co) = go_co co
-     go_prov (PluginProv _)      = emptyUniqSet
-     go_prov (CorePrepProv _)    = emptyUniqSet
+     go_dco ReflDCo                   = emptyUniqSet
+     go_dco (GReflRightDCo co)        = go_co co
+     go_dco (GReflLeftDCo  co)        = go_co co
+     go_dco (TyConAppDCo args)        = go_dcos args
+     go_dco (AppDCo co arg)           = go_dco co `unionUniqSets` go_dco arg
+     go_dco (ForAllDCo _ kind_dco co) = go_dco kind_dco `unionUniqSets` go_dco co
+     go_dco (AxiomInstDCo ax)         = go_ax ax
+     go_dco StepsDCo{}                = emptyUniqSet
+     go_dco (CoVarDCo {})             = emptyUniqSet
+     go_dco (TransDCo co1 co2)        = go_dco co1 `unionUniqSets` go_dco co2
+     go_dco (DehydrateCo co)          = go_co co
+     go_dco (UnivDCo p rhs)           = go_prov go_dco p `unionUniqSets` go rhs
+     go_dco (SubDCo dco)              = go_dco dco
+
+     go_prov get_tycons (PhantomProv co)    = get_tycons co
+     go_prov get_tycons (ProofIrrelProv co) = get_tycons co
+     go_prov _          (PluginProv _)      = emptyUniqSet
+     go_prov _          (CorePrepProv _)    = emptyUniqSet
         -- this last case can happen from the tyConsOfType used from
         -- checkTauTvUpdate
 
      go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos
+     go_dcos dcos = foldr (unionUniqSets . go_dco) emptyUniqSet dcos
 
      go_tc tc = unitUniqSet tc
      go_ax ax = go_tc $ coAxiomTyCon ax
@@ -1318,7 +1425,11 @@ occCheckExpand vs_to_avoid ty
 
     go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args
                                              ; return (AxiomInstCo ax ind args') }
-    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p
+    go_co ctx (HydrateDCo r ty1 dco ty2)= do { ty1' <- go ctx ty1
+                                             ; dco' <- go_dco ctx dco
+                                             ; ty2' <- go ctx ty2
+                                             ; return (HydrateDCo r ty1' dco'  ty2') }
+    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov (go_co cxt) p
                                              ; ty1' <- go cxt ty1
                                              ; ty2' <- go cxt ty2
                                              ; return (UnivCo p' r ty1' ty2') }
@@ -1342,8 +1453,38 @@ occCheckExpand vs_to_avoid ty
                                              ; return (AxiomRuleCo ax cs') }
 
     ------------------
-    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
-    go_prov _   p@(CorePrepProv _)  = return p
+    go_dco _   ReflDCo                = pure ReflDCo
+    go_dco cxt (GReflRightDCo co)     = GReflRightDCo <$> go_co cxt co
+    go_dco cxt (GReflLeftDCo  co)     = GReflLeftDCo  <$> go_co cxt co
+    go_dco cxt (TyConAppDCo args)     = do { args' <- mapM (go_dco cxt) args
+                                           ; return (TyConAppDCo args') }
+    go_dco cxt (AppDCo co arg)        = do { co' <- go_dco cxt co
+                                           ; arg' <- go_dco cxt arg
+                                           ; return (AppDCo co' arg') }
+    go_dco cxt@(as, env) (ForAllDCo tv kind_dco body_co)
+      = do { kind_dco' <- go_dco cxt kind_dco
+           ; tv_kind' <- go cxt (varType tv)
+           ; let tv' = setVarType tv $ tv_kind'
+                 env' = extendVarEnv env tv tv'
+                 as'  = as `delVarSet` tv
+           ; body' <- go_dco (as', env') body_co
+           ; return (ForAllDCo tv' kind_dco' body') }
+    go_dco (as,env) co@(CoVarDCo c)
+      | Just c' <- lookupVarEnv env c = return (CoVarDCo c')
+      | bad_var_occ as c              = Nothing
+      | otherwise                     = return co
+
+    go_dco _   dco@AxiomInstDCo{}     = pure dco
+    go_dco _   dco@StepsDCo{}         = pure dco
+    go_dco cxt (TransDCo co1 co2)     = do { co1' <- go_dco cxt co1
+                                           ; co2' <- go_dco cxt co2
+                                           ; return (TransDCo co1' co2') }
+    go_dco ctx (UnivDCo prov rhs)     = UnivDCo <$> go_prov (go_dco ctx) prov <*> go ctx rhs
+    go_dco ctx (SubDCo dco)           = SubDCo <$> go_dco ctx dco
+    go_dco cxt (DehydrateCo co)       = DehydrateCo <$> go_co cxt co
 
+    ------------------
+    go_prov prov_go (PhantomProv co)    = PhantomProv    <$> prov_go co
+    go_prov prov_go (ProofIrrelProv co) = ProofIrrelProv <$> prov_go co
+    go_prov _       p@(PluginProv _)    = return p
+    go_prov _       p@(CorePrepProv _)  = return p
diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs
index ce97294a94..2c0838f586 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs
+++ b/compiler/GHC/Core/TyCo/Ppr.hs
@@ -20,6 +20,7 @@ module GHC.Core.TyCo.Ppr
 
         -- * Pretty-printing coercions
         pprCo, pprParendCo,
+        pprDCo,
 
         debugPprType,
   ) where
@@ -28,7 +29,8 @@ import GHC.Prelude
 
 import {-# SOURCE #-} GHC.CoreToIface
    ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs
-   , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )
+   , toIfaceTyCon, toIfaceTcArgs
+   , toIfaceCoercionX, toIfaceDCoercionX )
 
 import {-# SOURCE #-} GHC.Core.DataCon
    ( dataConFullSig , dataConUserTyVarBinders, DataCon )
@@ -126,6 +128,9 @@ pprCo, pprParendCo :: Coercion -> SDoc
 pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)
 pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)
 
+pprDCo :: DCoercion -> SDoc
+pprDCo      co = getPprStyle $ \ sty -> pprIfaceDCoercion (tidyToIfaceDCoSty co sty)
+
 tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion
 tidyToIfaceCoSty co sty
   | userStyle sty = tidyToIfaceCo co
@@ -143,6 +148,27 @@ tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)
   where
     env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs
     free_tcvs = scopedSort $ tyCoVarsOfCoList co
+
+tidyToIfaceDCoSty :: DCoercion -> PprStyle -> IfaceDCoercion
+tidyToIfaceDCoSty co sty
+  | userStyle sty = tidyToIfaceDCo co
+  | otherwise     = toIfaceDCoercionX (tyCoVarsOfDCo co) co
+     -- in latter case, don't tidy, as we'll be printing uniques.
+
+tidyToIfaceDCo :: DCoercion -> IfaceDCoercion
+-- It's vital to tidy before converting to an IfaceType
+-- or nested binders will become indistinguishable!
+--
+-- Also for the free type variables, tell toIfaceDCoercionX to
+-- leave them as IfaceFreeCoVarDCo.  This is super-important
+-- for debug printing.
+tidyToIfaceDCo co = toIfaceDCoercionX (mkVarSet free_tcvs) (tidyDCo env co)
+  where
+    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs
+    free_tcvs = scopedSort $ tyCoVarsOfDCoList co
+
+
+
 ------------
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
diff --git a/compiler/GHC/Core/TyCo/Ppr.hs-boot b/compiler/GHC/Core/TyCo/Ppr.hs-boot
index c031db2f9a..0c32fbfbc8 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs-boot
+++ b/compiler/GHC/Core/TyCo/Ppr.hs-boot
@@ -1,12 +1,14 @@
 module GHC.Core.TyCo.Ppr where
 
 import {-# SOURCE #-} GHC.Types.Var ( TyVar )
-import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit)
+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, DCoercion, TyLit)
 import GHC.Utils.Outputable ( SDoc )
 
 pprType :: Type -> SDoc
 debugPprType :: Type -> SDoc
 pprKind :: Kind -> SDoc
 pprCo :: Coercion -> SDoc
+pprParendCo :: Coercion -> SDoc
+pprDCo :: DCoercion -> SDoc
 pprTyLit :: TyLit -> SDoc
 pprTyVar :: TyVar -> SDoc
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 245a1c507b..11e4b6db79 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -1,5 +1,6 @@
 
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GADTs #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
 
@@ -42,6 +43,9 @@ module GHC.Core.TyCo.Rep (
         CoercionN, CoercionR, CoercionP, KindCoercion,
         MCoercion(..), MCoercionR, MCoercionN,
 
+        DCoercion(..), DCoercionN, KindDCoercion,
+        CoOrDCo(..),
+
         -- * Functions over types
         mkNakedTyConTy, mkTyVarTy, mkTyVarTys,
         mkTyCoVarTy, mkTyCoVarTys,
@@ -61,7 +65,7 @@ module GHC.Core.TyCo.Rep (
         TyCoFolder(..), foldTyCo, noView,
 
         -- * Sizes
-        typeSize, typesSize, coercionSize, provSize,
+        typeSize, typesSize, coercionSize, dcoercionSize, provSize,
 
         -- * Multiplicities
         Scaled(..), scaledMult, scaledThing, mapScaledType, Mult
@@ -69,7 +73,7 @@ module GHC.Core.TyCo.Rep (
 
 import GHC.Prelude
 
-import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )
+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprParendCo, pprDCo, pprTyLit )
 import {-# SOURCE #-} GHC.Builtin.Types
 import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint )
 
@@ -882,9 +886,23 @@ data Coercion
     -- The number coercions should match exactly the expectations
     -- of the CoAxiomRule (i.e., the rule is fully saturated).
 
-  | UnivCo UnivCoProvenance Role Type Type
+  | UnivCo (UnivCoProvenance Coercion) Role Type Type
       -- :: _ -> "e" -> _ -> _ -> e
 
+  -- | Embed a directed coercion into a coercion, by specifying
+  -- the LHS type and role of the directed coercion.
+  --
+  -- The RHS type is also cached, as we often already know the RHS,
+  -- which avoids us computing it anew using 'followDCo'.
+  --
+  -- See Note [Directed coercions]
+  | HydrateDCo
+      Role -- ^ `r`
+      Type -- ^ `lhs`: LHS type of the directed coercion
+      DCoercion
+      Type -- ^ Cached RHS type of the directed coercion.
+           -- Can be computed from `r` and `lhs` using 'followDCo'.
+
   | SymCo Coercion             -- :: e -> e
   | TransCo Coercion Coercion  -- :: e -> e -> e
 
@@ -980,7 +998,7 @@ type MCoercionN = MCoercion
 
 instance Outputable MCoercion where
   ppr MRefl    = text "MRefl"
-  ppr (MCo co) = text "MCo" <+> ppr co
+  ppr (MCo co) = text "MCo" <+> pprParendCo co
 
 {- Note [Refl invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1402,6 +1420,152 @@ A more nuanced treatment might be able to relax this condition
 somewhat, by checking if t1 and/or t2 use their bound variables
 in nominal ways. If not, having w be representational is OK.
 
+Note [Directed coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A directed coercion is a compact representation of a coercion, used to avoid
+storing a large amount of extra types in coercions in the rewriter.
+
+Recall that a coercion always contains enough information for us to be
+able to retrieve its role and its left and right hand side types.
+
+Examples:
+
+  Refl ty
+    coercionRole: Nominal
+    coercionLKind: ty
+    coercionRKind: ty
+
+  TyConAppCo r tc cos
+    coercionRole: r
+    coercionLKind: mkTyConApp tc (map coercionLKind cos)
+    coercionRKind: mkTyConApp tc (map coercionRKind cos)
+
+In practice, this means that when rewriting type family applications,
+coercions end up storing large amounts of extra information:
+
+  type family a + b where
+    Zero   + b = b
+    Succ a + b = Succ (a + b)
+
+Reducing 5 + 0 gives rise to a coercion of the form
+
+  +[1] <Succ (Succ (Succ (Succ Zero)))> <Zero>
+  ; (Succ (+[1] <Succ (Succ (Succ Zero))> <Zero>
+      ; (Succ (+[1] <Succ (Succ Zero)> <Zero>
+          ; (Succ (+[1] <Succ Zero> <Zero>
+              ; (Succ (+[1] <Zero> <Zero>
+                  ; (Succ (+[0] <Zero>))))))))))
+
+Compare this to the corresponding directed coercion, where we don't store
+so many types:
+
+  Steps 1
+  ; (TyConApp (Steps 1
+      ; (TyConApp (Steps 1
+          ; (TyConApp (Steps 1
+              ; (TyConApp (Steps 1
+                  ; (TyConApp (Steps 1))))))))))
+
+To achieve this, we sacrifice being able to query what the LHS type of a
+directed coercion is. Instead, this information must be provided as an
+input. More specifically, when we have:
+
+  dco :: lhs ~r rhs
+
+We understand that the role `r` and the LHS type `lhs` are **inputs**,
+from which we are able to compute the RHS type `rhs`.
+(This is what the function followDCo does.)
+This allows us to get away with storing less information in a directed
+coercion than in an undirected coercion, while still retaining the ability
+to run Core Lint on our program.
+-}
+
+type DCoercionN    = DCoercion
+type KindDCoercion = DCoercionN
+
+-- | A directed coercion is a more compact representation of a coercion,
+-- which is used in the rewriter to avoid producing quadratically large
+-- coercions.
+--
+-- For a directed coercion @dco :: lhs ~r rhs@, we think of the role @r@
+-- and the LHS type @lhs@ as /inputs/. Only once this context is given
+-- are we able to compute the RHS type @rhs@.
+--
+-- See Note [Directed coercions].
+data DCoercion
+
+  -- | 'ReflCo' for 'DCoercion'.
+  = ReflDCo
+
+  -- | 'GReflCo' for 'DCoercion'.
+  | GReflRightDCo CoercionN
+
+  -- | @GReflLeftDCo mco@ corresponds to @SymCo (GReflCo mco)@.
+  --
+  -- We need this alongside @GReflRightDCo@ because we don't have
+  -- symmetry for directed coercions.
+  | GReflLeftDCo  CoercionN
+   -- SLD TODO: remove GReflLeftDCo? We could use @GReflRightDCo (mkSymMCo mco)@.
+
+  -- | 'TyConAppCo' for 'DCoercion'.
+  --
+  -- NB: we use 'TyConAppDCo' for functions too,
+  -- unlike coercions which have 'TyConAppCo' and 'FunCo'.
+  | TyConAppDCo [DCoercion]
+
+  -- | 'AppCo' for 'DCoercion'.
+  | AppDCo DCoercion DCoercionN
+
+  -- | 'ForAllCo' for 'DCoercion'.
+  | ForAllDCo TyCoVar KindDCoercion DCoercion
+
+  -- | 'CoVarCo' for 'DCoercion'.
+  | CoVarDCo CoVar
+
+  -- | 'AxiomInstCo' for 'DCoercion', but specialised
+  -- to open type family coercion axioms.
+  --
+  -- For newtypes and closed type families, we use the more
+  -- compact 'StepsDCo'.
+  | AxiomInstDCo (CoAxiom Branched)
+
+  -- | @StepsDCo n@ means: \"take n successive reduction steps\",
+  -- where a reduction step could be using a closed type family equation
+  -- or using a newtype axiom.
+  | StepsDCo !Int
+
+  -- | 'UnivCo' for 'DCoercion'. We only need to store the RHS type,
+  -- as the LHS type and role will be provided by context.
+  | UnivDCo
+      (UnivCoProvenance DCoercion)
+      Type -- ^ RHS type
+
+  -- | 'TransCo' for 'DCoercion'.
+  | TransDCo DCoercion DCoercion
+
+  -- | 'SubCo' for 'DCoercion'.
+  | SubDCo DCoercion
+
+  -- | Embed a coercion inside a directed coercion, e.g. \"forget\"
+  -- that we can compute its LHS type and role without context.
+  | DehydrateCo Coercion
+
+  deriving Data.Data
+
+instance Outputable DCoercion where
+  ppr = pprDCo
+
+-- | A convenient GADT for handling 'Coercion' and 'DCoercion'
+-- at the same time.
+data CoOrDCo co_or_dco where
+  Co  :: CoOrDCo Coercion
+  DCo :: CoOrDCo DCoercion
+
+instance Outputable (CoOrDCo co_or_dco) where
+  ppr Co  = text "Co"
+  ppr DCo = text "DCo"
+
+{-
 
 %************************************************************************
 %*                                                                      *
@@ -1425,25 +1589,25 @@ role and kind, which is done in the UnivCo constructor.
 -- It is reasonable to consider each constructor of 'UnivCoProvenance'
 -- as a totally independent coercion form; their only commonality is
 -- that they don't tell you what types they coercion between. (That info
--- is in the 'UnivCo' constructor of 'Coercion'.
-data UnivCoProvenance
-  = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom
-                             -- roled coercions
+-- is in the 'UnivCo' constructor of 'Coercion').
+data UnivCoProvenance kco
+  = PhantomProv kco -- ^ See Note [Phantom coercions]. Only in Phantom
+                    -- roled coercions
 
-  | ProofIrrelProv KindCoercion  -- ^ From the fact that any two coercions are
-                                 --   considered equivalent. See Note [ProofIrrelProv].
-                                 -- Can be used in Nominal or Representational coercions
+  | ProofIrrelProv kco  -- ^ From the fact that any two coercions are
+                        --   considered equivalent. See Note [ProofIrrelProv].
+                        -- Can be used in Nominal or Representational coercions
 
   | PluginProv String  -- ^ From a plugin, which asserts that this coercion
                        --   is sound. The string is for the use of the plugin.
 
-  | CorePrepProv       -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
+  | CorePrepProv       -- ^ See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep
       Bool   -- True  <=> the UnivCo must be homogeneously kinded
              -- False <=> allow hetero-kinded, e.g. Int ~ Int#
 
   deriving Data.Data
 
-instance Outputable UnivCoProvenance where
+instance Outputable (UnivCoProvenance kco) where
   ppr (PhantomProv _)    = text "(phantom)"
   ppr (ProofIrrelProv _) = text "(proof irrel.)"
   ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))
@@ -1708,14 +1872,17 @@ data TyCoFolder env a
       }
 
 {-# INLINE foldTyCo  #-}  -- See Note [Specialising foldType]
-foldTyCo :: Monoid a => TyCoFolder env a -> env
-         -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a)
+foldTyCo :: forall env a. Monoid a => TyCoFolder env a -> env
+         -> ( Type -> a, [Type] -> a
+            , Coercion -> a, [Coercion] -> a
+            , DCoercion -> a, [DCoercion] -> a
+            )
 foldTyCo (TyCoFolder { tcf_view       = view
                      , tcf_tyvar      = tyvar
                      , tcf_tycobinder = tycobinder
                      , tcf_covar      = covar
                      , tcf_hole       = cohole }) env
-  = (go_ty env, go_tys env, go_co env, go_cos env)
+  = (go_ty env, go_tys env, go_co env, go_cos env, go_dco env, go_dcos env)
   where
     go_ty env ty | Just ty' <- view ty = go_ty env ty'
     go_ty env (TyVarTy tv)      = tyvar env tv
@@ -1738,38 +1905,61 @@ foldTyCo (TyCoFolder { tcf_view       = view
     go_cos _   []     = mempty
     go_cos env (c:cs) = go_co env c `mappend` go_cos env cs
 
-    go_co env (Refl ty)                = go_ty env ty
-    go_co env (GRefl _ ty MRefl)       = go_ty env ty
-    go_co env (GRefl _ ty (MCo co))    = go_ty env ty `mappend` go_co env co
-    go_co env (TyConAppCo _ _ args)    = go_cos env args
-    go_co env (AppCo c1 c2)            = go_co env c1 `mappend` go_co env c2
-    go_co env (CoVarCo cv)             = covar env cv
-    go_co env (AxiomInstCo _ _ args)   = go_cos env args
-    go_co env (HoleCo hole)            = cohole env hole
-    go_co env (UnivCo p _ t1 t2)       = go_prov env p `mappend` go_ty env t1
-                                                       `mappend` go_ty env t2
-    go_co env (SymCo co)               = go_co env co
-    go_co env (TransCo c1 c2)          = go_co env c1 `mappend` go_co env c2
-    go_co env (AxiomRuleCo _ cos)      = go_cos env cos
-    go_co env (SelCo _ co)             = go_co env co
-    go_co env (LRCo _ co)              = go_co env co
-    go_co env (InstCo co arg)          = go_co env co `mappend` go_co env arg
-    go_co env (KindCo co)              = go_co env co
-    go_co env (SubCo co)               = go_co env co
-
-    go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })
-       = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2
-
-    go_co env (ForAllCo tv kind_co co)
-      = go_co env kind_co `mappend` go_ty env (varType tv)
-                          `mappend` go_co env' co
+    go_co env (Refl ty)                 = go_ty env ty
+    go_co env (GRefl _ ty MRefl)        = go_ty env ty
+    go_co env (GRefl _ ty (MCo co))     = go_ty env ty `mappend` go_co env co
+    go_co env (TyConAppCo _ _ args)     = go_cos env args
+    go_co env (AppCo c1 c2)             = go_co env c1 `mappend` go_co env c2
+    go_co env (FunCo _ _ _ cw c1 c2)    = go_co env cw `mappend`
+                                          go_co env c1 `mappend`
+                                          go_co env c2
+    go_co env (CoVarCo cv)              = covar env cv
+    go_co env (AxiomInstCo _ _ args)    = go_cos env args
+    go_co env (HoleCo hole)             = cohole env hole
+    go_co env (HydrateDCo _ t1 dco _t2) = go_ty env t1 `mappend` go_dco env dco
+    go_co env (UnivCo p _ t1 t2)        = go_prov go_co env p
+                                            `mappend` go_ty env t1
+                                            `mappend` go_ty env t2
+    go_co env (SymCo co)                = go_co env co
+    go_co env (TransCo co1 co2)         = go_co env co1 `mappend` go_co env co2
+    go_co env (AxiomRuleCo _ cos)       = go_cos env cos
+    go_co env (SelCo _ co)              = go_co env co
+    go_co env (LRCo _ co)               = go_co env co
+    go_co env (InstCo co arg)           = go_co env co `mappend` go_co env arg
+    go_co env (KindCo co)               = go_co env co
+    go_co env (SubCo co)                = go_co env co
+    go_co env (ForAllCo tv kind_co co)  = go_co env kind_co
+                                            `mappend` go_ty env (varType tv)
+                                            `mappend` go_co env' co
+      where
+        !env' = tycobinder env tv Inferred
+
+    go_dcos _   []     = mempty
+    go_dcos env (c:cs) = go_dco env c `mappend` go_dcos env cs
+
+    go_dco _   ReflDCo                    = mempty
+    go_dco env (GReflRightDCo co)         = go_co env co
+    go_dco env (GReflLeftDCo co)          = go_co env co
+    go_dco env (TyConAppDCo args)         = go_dcos env args
+    go_dco env (AppDCo c1 c2)             = go_dco env c1 `mappend` go_dco env c2
+    go_dco env (CoVarDCo cv)              = covar env cv
+    go_dco _   AxiomInstDCo{}             = mempty
+    go_dco _   StepsDCo{}                 = mempty
+    go_dco env (TransDCo co1 co2)         = go_dco env co1 `mappend` go_dco env co2
+    go_dco env (SubDCo dco)               = go_dco env dco
+    go_dco env (DehydrateCo co)           = go_co env co
+    go_dco env (ForAllDCo tv kind_dco co) = go_dco env kind_dco
+                                              `mappend` go_ty env (varType tv)
+                                              `mappend` go_dco env' co
       where
-        env' = tycobinder env tv Inferred
+        !env' = tycobinder env tv Inferred
+    go_dco env (UnivDCo prov t2)       = go_prov go_dco env prov `mappend` go_ty env t2
 
-    go_prov env (PhantomProv co)    = go_co env co
-    go_prov env (ProofIrrelProv co) = go_co env co
-    go_prov _   (PluginProv _)      = mempty
-    go_prov _   (CorePrepProv _)    = mempty
+    go_prov :: (env ->co -> a) -> env -> UnivCoProvenance co -> a
+    go_prov do_fold env (PhantomProv co)    = do_fold env co
+    go_prov do_fold env (ProofIrrelProv co) = do_fold env co
+    go_prov _       _   (PluginProv _)      = mempty
+    go_prov _       _   (CorePrepProv _)    = mempty
 
 -- | A view function that looks through nothing.
 noView :: Type -> Maybe Type
@@ -1821,7 +2011,8 @@ coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2
 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 (HydrateDCo _ t1 dco t2) = 1 + typeSize t1 + dcoercionSize dco + typeSize t2
+coercionSize (UnivCo p _ t1 t2)  = 1 + provSize coercionSize p + typeSize t1 + typeSize t2
 coercionSize (SymCo co)          = 1 + coercionSize co
 coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2
 coercionSize (SelCo _ co)        = 1 + coercionSize co
@@ -1831,11 +2022,26 @@ coercionSize (KindCo co)         = 1 + coercionSize co
 coercionSize (SubCo co)          = 1 + coercionSize co
 coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)
 
-provSize :: UnivCoProvenance -> Int
-provSize (PhantomProv co)    = 1 + coercionSize co
-provSize (ProofIrrelProv co) = 1 + coercionSize co
-provSize (PluginProv _)      = 1
-provSize (CorePrepProv _)    = 1
+dcoercionSize :: DCoercion -> Int
+dcoercionSize ReflDCo            = 1
+dcoercionSize (GReflRightDCo co) = 1 + coercionSize co
+dcoercionSize (GReflLeftDCo  co) = 1 + coercionSize co
+dcoercionSize (TyConAppDCo args) = 1 + sum (map dcoercionSize args)
+dcoercionSize (AppDCo co arg)    = dcoercionSize co + dcoercionSize arg
+dcoercionSize (ForAllDCo _ h co) = 1 + dcoercionSize co + dcoercionSize h
+dcoercionSize (CoVarDCo _)       = 1
+dcoercionSize AxiomInstDCo{}     = 1
+dcoercionSize StepsDCo{}         = 1
+dcoercionSize (TransDCo co1 co2) = 1 + dcoercionSize co1 + dcoercionSize co2
+dcoercionSize (SubDCo co)        = 1 + dcoercionSize co
+dcoercionSize (DehydrateCo co)   = 1 + coercionSize co
+dcoercionSize (UnivDCo prov rhs) = 1 + provSize dcoercionSize prov + typeSize rhs
+
+provSize :: (co -> Int) -> UnivCoProvenance co -> Int
+provSize co_size (PhantomProv co)    = 1 + co_size co
+provSize co_size (ProofIrrelProv co) = 1 + co_size co
+provSize _       (PluginProv _)      = 1
+provSize _       (CorePrepProv _)    = 1
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index 9b82d3cfa5..714b6371f1 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -9,8 +9,9 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
 data Type
 data Coercion
 data FunSel
+data DCoercion
 data CoSel
-data UnivCoProvenance
+data UnivCoProvenance co
 data TyLit
 data MCoercion
 
diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs
index 4224bd127b..ee25e16f75 100644
--- a/compiler/GHC/Core/TyCo/Subst.hs
+++ b/compiler/GHC/Core/TyCo/Subst.hs
@@ -6,6 +6,7 @@ Type and Coercion - friends' interface
 
 
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
 
 -- | Substitution into types and coercions.
 module GHC.Core.TyCo.Subst
@@ -35,17 +36,19 @@ module GHC.Core.TyCo.Subst
         substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked,
         substTyWithUnchecked, substScaledTyUnchecked,
         substCoUnchecked, substCoWithUnchecked,
+        substDCoUnchecked,
         substTyWithInScope,
         substTys, substScaledTys, substTheta,
         lookupTyVar,
         substCo, substCos, substCoVar, substCoVars, lookupCoVar,
+        substDCo,
         cloneTyVarBndr, cloneTyVarBndrs,
         substVarBndr, substVarBndrs,
         substTyVarBndr, substTyVarBndrs,
         substCoVarBndr,
         substTyVar, substTyVars, substTyVarToTyVar,
         substTyCoVars,
-        substTyCoBndr, substForAllCoBndr,
+        substTyCoBndr, substForAllDCoBndr, substForAllCoBndr,
         substVarBndrUsing, substForAllCoBndrUsing,
         checkValidSubst, isValidTCvSubst,
   ) where
@@ -61,7 +64,11 @@ import {-# SOURCE #-} GHC.Core.Coercion
    , mkAxiomInstCo, mkAppCo, mkGReflCo
    , mkInstCo, mkLRCo, mkTyConAppCo
    , mkCoercionType
-   , coercionKind, coercionLKind, coVarKindsTypesRole )
+   , mkTyConAppDCo
+   , mkAppDCo, mkForAllDCo, mkReflDCo, mkTransDCo
+   , mkGReflRightDCo, mkGReflLeftDCo
+   , mkHydrateDCo, mkDehydrateCo, mkUnivDCo
+   , coercionKind, coercionLKind, coVarKindsTypesRole)
 import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )
 import {-# SOURCE #-} GHC.Core.Ppr ( )
 import {-# SOURCE #-} GHC.Core ( CoreExpr )
@@ -682,8 +689,8 @@ isValidTCvSubst (Subst in_scope _ tenv cenv) =
 
 -- | This checks if the substitution satisfies the invariant from
 -- Note [The substitution invariant].
-checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a
-checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a
+checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> [DCoercion] -> a -> a
+checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos dcos a
   = assertPpr (isValidTCvSubst subst)
               (text "in_scope" <+> ppr in_scope $$
                text "tenv" <+> ppr tenv $$
@@ -691,13 +698,15 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a
                text "cenv" <+> ppr cenv $$
                text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$
                text "tys" <+> ppr tys $$
-               text "cos" <+> ppr cos) $
+               text "cos" <+> ppr cos $$
+               text "dcos" <+> ppr dcos) $
     assertPpr tysCosFVsInScope
               (text "in_scope" <+> ppr in_scope $$
                text "tenv" <+> ppr tenv $$
                text "cenv" <+> ppr cenv $$
                text "tys" <+> ppr tys $$
                text "cos" <+> ppr cos $$
+               text "dcos" <+> ppr dcos $$
                text "needInScope" <+> ppr needInScope)
     a
   where
@@ -705,7 +714,8 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a
     -- It's OK to use nonDetKeysUFM here, because we only use this list to
     -- remove some elements from a set
   needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet`
-                 shallowTyCoVarsOfCos cos)
+                 shallowTyCoVarsOfCos cos `unionVarSet`
+                 shallowTyCoVarsOfDCos dcos)
                 `delListFromUniqSet_Directly` substDomain
   tysCosFVsInScope = needInScope `varSetInScope` in_scope
 
@@ -716,7 +726,7 @@ checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a
 substTy :: HasDebugCallStack => Subst -> Type  -> Type
 substTy subst ty
   | isEmptyTCvSubst    subst = ty
-  | otherwise             = checkValidSubst subst [ty] [] $
+  | otherwise             = checkValidSubst subst [ty] [] [] $
                             subst_ty subst ty
 
 -- | Substitute within a 'Type' disabling the sanity checks.
@@ -741,12 +751,12 @@ substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst)
 substTys :: HasDebugCallStack => Subst -> [Type] -> [Type]
 substTys subst tys
   | isEmptyTCvSubst subst = tys
-  | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys
+  | otherwise = checkValidSubst subst tys [] [] $ map (subst_ty subst) tys
 
 substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type]
 substScaledTys subst scaled_tys
   | isEmptyTCvSubst subst = scaled_tys
-  | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $
+  | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] [] $
                 map (mapScaledType (subst_ty subst)) scaled_tys
 
 -- | Substitute within several 'Type's disabling the sanity checks.
@@ -846,13 +856,31 @@ lookupTyVar (Subst _ _ tenv _) tv
   = assert (isTyVar tv )
     lookupVarEnv tenv tv
 
+-- | Substitute within a 'DCoercion'
+-- The substitution has to satisfy the invariants described in
+-- Note [The substitution invariant].
+substDCo :: HasDebugCallStack => Subst -> DCoercion -> DCoercion
+substDCo subst dco
+  | isEmptyTCvSubst subst = dco
+  | otherwise = checkValidSubst subst [] [] [dco] $ subst_dco subst dco
+
+-- | Substitute within a 'DCoercion' disabling 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 substDCoUnchecked to
+-- substDCo and remove this function. Please don't use in new code.
+substDCoUnchecked :: Subst -> DCoercion -> DCoercion
+substDCoUnchecked subst co
+  | isEmptyTCvSubst subst = co
+  | otherwise = subst_dco subst co
+
 -- | Substitute within a 'Coercion'
 -- The substitution has to satisfy the invariants described in
 -- Note [The substitution invariant].
 substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion
 substCo subst co
   | isEmptyTCvSubst subst = co
-  | otherwise = checkValidSubst subst [] [co] $ subst_co subst co
+  | otherwise = checkValidSubst subst [] [co] [] $ subst_co subst co
 
 -- | Substitute within a 'Coercion' disabling sanity checks.
 -- The problems that the sanity checks in substCo catch are described in
@@ -870,18 +898,23 @@ substCoUnchecked subst co
 substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion]
 substCos subst cos
   | isEmptyTCvSubst subst = cos
-  | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos
+  | otherwise = checkValidSubst subst [] cos [] $ map (subst_co subst) cos
 
 subst_co :: Subst -> Coercion -> Coercion
-subst_co subst co
-  = go co
+subst_co = fst . subst_co_dco
+
+subst_dco :: Subst -> DCoercion -> DCoercion
+subst_dco = snd . subst_co_dco
+
+subst_co_dco :: Subst -> (Coercion -> Coercion, DCoercion -> DCoercion)
+subst_co_dco subst = (go, go_dco)
   where
     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_mco (MCo co) = MCo $! go co
 
     go :: Coercion -> Coercion
     go (Refl ty)             = mkNomReflCo $! (go_ty ty)
@@ -896,7 +929,10 @@ subst_co subst co
     go (FunCo r afl afr w co1 co2)   = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2
     go (CoVarCo cv)          = substCoVar subst cv
     go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos
-    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov p) $! r) $!
+    go (HydrateDCo r ty dco rty) = (((mkHydrateDCo $! r) $! go_ty ty) $! go_dco dco) $! go_ty rty
+      -- Here we can either substitute the RHS or recompute it from the rest of the information.
+
+    go (UnivCo p r t1 t2)    = (((mkUnivCo $! go_prov go p) $! r) $!
                                 (go_ty t1)) $! (go_ty t2)
     go (SymCo co)            = mkSymCo $! (go co)
     go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)
@@ -909,10 +945,30 @@ subst_co subst co
                                 in cs1 `seqList` AxiomRuleCo c cs1
     go (HoleCo h)            = HoleCo $! go_hole h
 
-    go_prov (PhantomProv kco)    = PhantomProv (go kco)
-    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)
-    go_prov p@(PluginProv _)     = p
-    go_prov p@(CorePrepProv _)   = p
+    go_dco :: DCoercion -> DCoercion
+    go_dco ReflDCo                = mkReflDCo
+    go_dco (GReflRightDCo co)     = mkGReflRightDCo $! go co
+    go_dco (GReflLeftDCo  co)     = mkGReflLeftDCo  $! go co
+    go_dco (TyConAppDCo args)     = let args' = map go_dco args
+                                    in  args' `seqList` mkTyConAppDCo args'
+    go_dco (AppDCo co arg)        = (mkAppDCo $! go_dco co) $! go_dco arg
+    go_dco (CoVarDCo cv)          = mkDehydrateCo $! substCoVar subst cv
+    go_dco dco@AxiomInstDCo{}     = dco
+    go_dco dco@StepsDCo{}         = dco
+    go_dco (TransDCo co1 co2)     = (mkTransDCo $! go_dco co1) $! go_dco co2
+    go_dco (DehydrateCo co)       = mkDehydrateCo $! go co
+    go_dco (ForAllDCo tv kind_dco co)
+      = case substForAllDCoBndrUnchecked subst tv kind_dco of
+         (subst', tv', kind_dco') ->
+          ((mkForAllDCo $! tv') $! kind_dco') $! subst_dco subst' co
+    go_dco (UnivDCo prov rhs)     = (mkUnivDCo (go_prov go_dco prov)) $! go_ty rhs
+    go_dco (SubDCo dco)           = SubDCo $ go_dco dco
+
+    go_prov :: (co -> co) -> UnivCoProvenance co -> UnivCoProvenance co
+    go_prov do_subst (PhantomProv kco)    = PhantomProv $! do_subst kco
+    go_prov do_subst (ProofIrrelProv kco) = ProofIrrelProv $! do_subst kco
+    go_prov _        p@(PluginProv _)     = p
+    go_prov _        p@(CorePrepProv _)   = p
 
     -- See Note [Substituting in a coercion hole]
     go_hole h@(CoercionHole { ch_co_var = cv })
@@ -921,7 +977,12 @@ subst_co subst co
 substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion
                   -> (Subst, TyCoVar, Coercion)
 substForAllCoBndr subst
-  = substForAllCoBndrUsing False (substCo subst) subst
+  = substForAllCoBndrUsing Co False (substTy subst) (substCo subst) subst
+
+substForAllDCoBndr :: Subst -> TyCoVar -> KindDCoercion
+                  -> (Subst, TyCoVar, DCoercion)
+substForAllDCoBndr subst
+  = substForAllCoBndrUsing DCo False (substTy subst) (substDCo subst) subst
 
 -- | Like 'substForAllCoBndr', but disables sanity checks.
 -- The problems that the sanity checks in substCo catch are described in
@@ -931,65 +992,94 @@ substForAllCoBndr subst
 substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion
                            -> (Subst, TyCoVar, Coercion)
 substForAllCoBndrUnchecked subst
-  = substForAllCoBndrUsing False (substCoUnchecked subst) subst
+  = substForAllCoBndrUsing Co False (substTyUnchecked subst) (substCoUnchecked subst) subst
+
+substForAllDCoBndrUnchecked :: Subst -> TyCoVar -> KindDCoercion
+                           -> (Subst, TyCoVar, DCoercion)
+substForAllDCoBndrUnchecked subst
+  = substForAllCoBndrUsing DCo False (substTyUnchecked subst) (substDCoUnchecked subst) subst
+
 
 -- See Note [Sym and ForAllCo]
-substForAllCoBndrUsing :: Bool  -- apply sym to binder?
-                       -> (Coercion -> Coercion)  -- transformation to kind co
-                       -> Subst -> TyCoVar -> KindCoercion
-                       -> (Subst, 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
-                            -> Subst -> TyVar -> KindCoercion
-                            -> (Subst, TyVar, KindCoercion)
-substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
+substForAllCoBndrUsing :: CoOrDCo kco
+                       -> Bool  -- apply sym to binder?
+                       -> (Type -> Type)
+                       -> (kco -> kco)  -- transformation to kind co
+                       -> Subst -> TyCoVar -> kco
+                       -> (Subst, TyCoVar, kco)
+substForAllCoBndrUsing co_or_dco sym sty sco subst old_var
+  | isTyVar old_var = substForAllCoTyVarBndrUsing co_or_dco sym sty sco subst old_var
+  | otherwise       = substForAllCoCoVarBndrUsing co_or_dco sym sty sco subst old_var
+
+substForAllCoTyVarBndrUsing :: CoOrDCo kco
+                            -> Bool  -- apply sym to binder?
+                            -> (Type -> Type) -- transformation to types
+                            -> (kco -> kco)  -- transformation to kind co
+                            -> Subst -> TyVar -> kco
+                            -> (Subst, TyVar, kco)
+substForAllCoTyVarBndrUsing co_or_dco sym sty sco (Subst in_scope idenv tenv cenv) old_var old_kind_co
   = assert (isTyVar old_var )
     ( Subst (in_scope `extendInScopeSet` new_var) idenv 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
+                          mk_cast (TyVarTy new_var) new_kind_co
             | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
 
-    no_kind_change = noFreeVarsOfCo old_kind_co
+    no_kind_change = case co_or_dco of
+      Co  -> noFreeVarsOfCo old_kind_co
+      DCo -> noFreeVarsOfDCo old_kind_co
+    mk_cast = case co_or_dco of
+      Co  -> CastTy
+      DCo -> pprPanic "substForAllCoTyVarBndrUsing DCo Sym"
+              (vcat [ text "kind_co:" <+> ppr 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
 
-    new_ki1 = coercionLKind new_kind_co
+    new_ki1 = case co_or_dco of
+      Co  -> coercionLKind 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.
+      DCo -> sty (tyVarKind old_var)
 
     new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)
 
-substForAllCoCoVarBndrUsing :: Bool  -- apply sym to binder?
-                            -> (Coercion -> Coercion)  -- transformation to kind co
-                            -> Subst -> CoVar -> KindCoercion
-                            -> (Subst, CoVar, KindCoercion)
-substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv)
+substForAllCoCoVarBndrUsing :: CoOrDCo kco
+                            -> Bool  -- apply sym to binder?
+                            -> (Type -> Type) -- transformation to types
+                            -> (kco -> kco)  -- transformation to kind co
+                            -> Subst -> CoVar -> kco
+                            -> (Subst, CoVar, kco)
+substForAllCoCoVarBndrUsing co_or_dco sym sty sco (Subst in_scope idenv tenv cenv)
                             old_var old_kind_co
-  = assert (isCoVar old_var )
+  = assert (isCoVar old_var)
     ( Subst (in_scope `extendInScopeSet` new_var) idenv 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_kind_change = case co_or_dco of
+      Co  -> noFreeVarsOfCo old_kind_co
+      DCo -> noFreeVarsOfDCo 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
+    Pair h1 h2 = case co_or_dco of
+      Co  -> coercionKind new_kind_co
+      DCo ->
+        let l_ty = sty (varType old_var)
+            r_ty = pprPanic "substForAllCoCoVarBndrUsing DCo Sym"
+                   (vcat [ text "kind_co:" <+> ppr old_kind_co])
+        in Pair l_ty r_ty
 
     new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type
     new_var_type  | sym       = h2
diff --git a/compiler/GHC/Core/TyCo/Tidy.hs b/compiler/GHC/Core/TyCo/Tidy.hs
index bfd7e4c7cc..7e7bdf433d 100644
--- a/compiler/GHC/Core/TyCo/Tidy.hs
+++ b/compiler/GHC/Core/TyCo/Tidy.hs
@@ -12,6 +12,7 @@ module GHC.Core.TyCo.Tidy
         tidyTyCoVarOcc,
         tidyTopType,
         tidyCo, tidyCos,
+        tidyDCo,
         tidyForAllTyBinder, tidyForAllTyBinders
   ) where
 
@@ -218,8 +219,13 @@ tidyTopType ty = tidyType emptyTidyEnv ty
 --
 -- See Note [Strictness in tidyType and friends]
 tidyCo :: TidyEnv -> Coercion -> Coercion
-tidyCo env@(_, subst) co
-  = go co
+tidyCo = fst . tidyCoDCo
+
+tidyDCo :: TidyEnv -> DCoercion -> DCoercion
+tidyDCo = snd . tidyCoDCo
+
+tidyCoDCo :: TidyEnv -> (Coercion -> Coercion, DCoercion -> DCoercion)
+tidyCoDCo env@(_, subst) = (go, go_dco)
   where
     go_mco MRefl    = MRefl
     go_mco (MCo co) = MCo $! go co
@@ -238,7 +244,8 @@ tidyCo env@(_, subst) co
                                  Just cv' -> CoVarCo cv'
     go (HoleCo h)            = HoleCo h
     go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos
-    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!
+    go (HydrateDCo r t1 dco rty) = ((HydrateDCo r $! tidyType env t1) $! go_dco dco) $! tidyType env rty
+    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov go p)) $! r) $!
                                 tidyType env t1) $! tidyType env t2
     go (SymCo co)            = SymCo $! go co
     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
@@ -249,10 +256,30 @@ tidyCo env@(_, subst) co
     go (SubCo co)            = SubCo $! go co
     go (AxiomRuleCo ax cos)  = AxiomRuleCo ax $ strictMap go cos
 
-    go_prov (PhantomProv co)    = PhantomProv $! go co
-    go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co
-    go_prov p@(PluginProv _)    = p
-    go_prov p@(CorePrepProv _)  = p
+    go_dco ReflDCo                = ReflDCo
+    go_dco (GReflRightDCo co)     = GReflRightDCo $! go co
+    go_dco (GReflLeftDCo  co)     = GReflLeftDCo  $! go co
+    go_dco (TyConAppDCo cos)      = TyConAppDCo $! strictMap go_dco cos
+    go_dco (AppDCo co1 co2)       = (AppDCo $! go_dco co1) $! go_dco co2
+    go_dco (ForAllDCo tv h co)    = ((ForAllDCo $! tvp) $! (go_dco h)) $! tidyDCo envp co
+                               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_dco (CoVarDCo cv)      = case lookupVarEnv subst cv of
+                                  Nothing  -> CoVarDCo cv
+                                  Just cv' -> CoVarDCo cv'
+    go_dco dco@AxiomInstDCo{} = dco
+    go_dco dco@StepsDCo{}     = dco
+    go_dco (TransDCo co1 co2) = (TransDCo $! go_dco co1) $! go_dco co2
+    go_dco (DehydrateCo co)   = DehydrateCo $! go co
+    go_dco (SubDCo dco)       = SubDCo $! go_dco dco
+    go_dco (UnivDCo prov rhs) = (UnivDCo $! go_prov go_dco prov) $! tidyType env rhs
+
+    go_prov :: (co -> co) -> UnivCoProvenance co -> UnivCoProvenance co
+    go_prov do_tidy (PhantomProv co)    = PhantomProv $! do_tidy co
+    go_prov do_tidy (ProofIrrelProv co) = ProofIrrelProv $! do_tidy co
+    go_prov _       p@(PluginProv _)    = p
+    go_prov _       p@(CorePrepProv _)  = p
 
 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
 tidyCos env = strictMap (tidyCo env)
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index a5dc5a6865..51147f5d60 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -38,7 +38,6 @@ module GHC.Core.Type (
         funTyConAppTy_maybe, funTyFlagTyCon,
         tyConAppFunTy_maybe, tyConAppFunCo_maybe,
         mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag,
-
         mkTyConApp, mkTyConTy,
         tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,
         tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
@@ -276,8 +275,16 @@ import {-# SOURCE #-} GHC.Core.Coercion
    , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
    , mkKindCo, mkSubCo, mkFunCo, funRole
    , decomposePiCos, coercionKind
-   , coercionRKind, coercionType
+   , mkTyConAppDCo, mkAppDCo
+   , mkForAllDCo
+   , mkTransDCo
+   , mkReflDCo, mkGReflRightDCo, mkGReflLeftDCo
+   , mkDehydrateCo
+   , mkHydrateDCo
+   , decomposePiCos
+   , coercionKind, coercionRKind, coercionType
    , isReflexiveCo, seqCo
+   , mkUnivDCo
    , topNormaliseNewType_maybe
    )
 import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar )
@@ -557,8 +564,10 @@ expandTypeSynonyms ty
       = substCoVar subst cv
     go_co subst (AxiomInstCo ax ind args)
       = mkAxiomInstCo ax ind (map (go_co subst) args)
+    go_co subst (HydrateDCo r t1 dco t2)
+      = mkHydrateDCo r (go subst t1) (go_dco subst dco) (go subst t2)
     go_co subst (UnivCo p r t1 t2)
-      = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2)
+      = mkUnivCo (go_prov (go_co subst) p) r (go subst t1) (go subst t2)
     go_co subst (SymCo co)
       = mkSymCo (go_co subst co)
     go_co subst (TransCo co1 co2)
@@ -578,16 +587,42 @@ expandTypeSynonyms ty
     go_co _ (HoleCo h)
       = pprPanic "expandTypeSynonyms hit a hole" (ppr h)
 
-    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 _     p@(CorePrepProv _)  = p
+    go_dco _     ReflDCo
+      = mkReflDCo
+    go_dco subst (GReflRightDCo co)
+      = mkGReflRightDCo (go_co subst co)
+    go_dco subst (GReflLeftDCo co)
+      = mkGReflLeftDCo (go_co subst co)
+    go_dco subst (TyConAppDCo args)
+      = mkTyConAppDCo (map (go_dco subst) args)
+    go_dco subst (AppDCo co arg)
+      = mkAppDCo (go_dco subst co) (go_dco subst arg)
+    go_dco subst (ForAllDCo tv kind_dco co)
+      = let (subst', tv', kind_dco') = go_dcobndr subst tv kind_dco in
+        mkForAllDCo tv' kind_dco' (go_dco subst' co)
+    go_dco subst (CoVarDCo cv)
+      = mkDehydrateCo (substCoVar subst cv)
+    go_dco _     dco@AxiomInstDCo{}
+      = dco
+    go_dco _     dco@StepsDCo{}
+      = dco
+    go_dco subst (TransDCo co1 co2)
+      = mkTransDCo (go_dco subst co1) (go_dco subst co2)
+    go_dco subst (DehydrateCo co) = mkDehydrateCo (go_co subst co)
+    go_dco subst (UnivDCo p rhs)  = mkUnivDCo (go_prov (go_dco subst) p) (go subst rhs)
+    go_dco subst (SubDCo dco)     = SubDCo (go_dco subst dco)
+
+    go_prov do_subst (PhantomProv co)    = PhantomProv    $ do_subst co
+    go_prov do_subst (ProofIrrelProv co) = ProofIrrelProv $ do_subst co
+    go_prov _        p@(PluginProv _)    = p
+    go_prov _        p@(CorePrepProv _)  = p
 
       -- the "False" and "const" are to accommodate the type of
       -- substForAllCoBndrUsing, which is general enough to
       -- handle coercion optimization (which sometimes swaps the
       -- order of a coercion)
-    go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst
+    go_cobndr  subst = substForAllCoBndrUsing Co  False (go subst) (go_co  subst) subst
+    go_dcobndr subst = substForAllCoBndrUsing DCo False (go subst) (go_dco subst) subst
 
 {- Notes on type synonyms
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -960,24 +995,26 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
     go_mco _   MRefl    = return MRefl
     go_mco env (MCo co) = MCo <$> (go_co env co)
 
-    go_co env (Refl ty)                  = Refl <$> go_ty env ty
-    go_co env (GRefl r ty mco)           = mkGReflCo r <$> go_ty env ty <*> go_mco env mco
-    go_co env (AppCo c1 c2)              = mkAppCo <$> go_co env c1 <*> go_co env c2
+    go_co env (Refl ty)           = Refl <$> go_ty env ty
+    go_co env (GRefl r ty mco)    = mkGReflCo r <$> go_ty env ty <*> go_mco env mco
+    go_co env (AppCo c1 c2)       = mkAppCo <$> go_co env c1 <*> go_co env c2
     go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw
                                            <*> go_co env c1 <*> go_co env c2
-    go_co env (CoVarCo cv)               = covar env cv
-    go_co env (HoleCo hole)              = cohole env hole
-    go_co env (UnivCo p r t1 t2)         = mkUnivCo <$> go_prov env p <*> pure r
-                                           <*> go_ty env t1 <*> go_ty env t2
-    go_co env (SymCo co)                 = mkSymCo <$> go_co env co
-    go_co env (TransCo c1 c2)            = mkTransCo <$> go_co env c1 <*> go_co env c2
-    go_co env (AxiomRuleCo r cos)        = AxiomRuleCo r <$> go_cos env cos
-    go_co env (SelCo i co)               = mkSelCo i <$> go_co env co
-    go_co env (LRCo lr co)               = mkLRCo lr <$> go_co env co
-    go_co env (InstCo co arg)            = mkInstCo <$> go_co env co <*> go_co env arg
-    go_co env (KindCo co)                = mkKindCo <$> go_co env co
-    go_co env (SubCo co)                 = mkSubCo <$> go_co env co
-    go_co env (AxiomInstCo ax i cos)     = mkAxiomInstCo ax i <$> go_cos env cos
+    go_co env (CoVarCo cv)        = covar env cv
+    go_co env (HoleCo hole)       = cohole env hole
+    go_co env (HydrateDCo r t1 dco t2) = mkHydrateDCo r <$> go_ty env t1 <*> go_dco env dco <*> go_ty env t2
+    go_co env (UnivCo p r t1 t2)  = mkUnivCo <$> go_prov (go_co env) p <*> pure r
+                                    <*> go_ty env t1 <*> go_ty env t2
+    go_co env (SymCo co)          = mkSymCo <$> go_co env co
+    go_co env (TransCo c1 c2)     = mkTransCo <$> go_co env c1 <*> go_co env c2
+    go_co env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos
+    go_co env (SelCo i co)        = mkSelCo i <$> go_co env co
+    go_co env (LRCo lr co)        = mkLRCo lr <$> go_co env co
+    go_co env (InstCo co arg)     = mkInstCo <$> go_co env co <*> go_co env arg
+    go_co env (KindCo co)         = mkKindCo <$> go_co env co
+    go_co env (SubCo co)          = mkSubCo <$> go_co env co
+    go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos
+
     go_co env co@(TyConAppCo r tc cos)
       | isTcTyCon tc
       = do { tc' <- tycon tc
@@ -996,10 +1033,38 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
            ; return $ mkForAllCo tv' kind_co' co' }
         -- See Note [Efficiency for ForAllCo case of mapTyCoX]
 
-    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@(CorePrepProv _)  = return p
+    go_dcos _   []       = return []
+    go_dcos env (co:cos) = (:) <$> go_dco env co <*> go_dcos env cos
+
+    go_dco _   ReflDCo                = pure mkReflDCo
+    go_dco env (GReflRightDCo co)     = mkGReflRightDCo <$> go_co env co
+    go_dco env (GReflLeftDCo  co)     = mkGReflLeftDCo  <$> go_co env co
+    go_dco env (AppDCo c1 c2)         = mkAppDCo <$> go_dco env c1 <*> go_dco env c2
+    go_dco env (CoVarDCo cv)          = mkDehydrateCo <$> covar env cv
+    go_dco env (TransDCo c1 c2)       = mkTransDCo <$> go_dco env c1 <*> go_dco env c2
+    go_dco _   dco@AxiomInstDCo{}     = pure dco
+    go_dco _   dco@StepsDCo{}         = pure dco
+    go_dco env (DehydrateCo co)       = mkDehydrateCo <$> go_co env co
+    go_dco env co@(TyConAppDCo cos)
+      -- Not a TcTyCon
+      | null cos    -- Avoid allocation in this very
+      = return co   -- common case (E.g. Int, LiftedRep etc)
+
+      | otherwise
+      = mkTyConAppDCo <$> go_dcos env cos
+    go_dco env (ForAllDCo tv kind_dco co)
+      = do { kind_dco' <- go_dco env kind_dco
+           ; (env', tv') <- tycobinder env tv Inferred
+           ; co' <- go_dco env' co
+           ; return $ mkForAllDCo tv' kind_dco' co' }
+        -- See Note [Efficiency for ForAllCo case of mapTyCoX]
+    go_dco env (UnivDCo p rhs)     = mkUnivDCo <$> go_prov (go_dco env) p <*> go_ty env rhs
+    go_dco env (SubDCo dco)        = SubDCo <$> go_dco env dco
+
+    go_prov go (PhantomProv co)    = PhantomProv    <$> go co
+    go_prov go (ProofIrrelProv co) = ProofIrrelProv <$> go co
+    go_prov _  p@(PluginProv _)    = return p
+    go_prov _  p@(CorePrepProv _)  = return p
 
 
 {- *********************************************************************
diff --git a/compiler/GHC/Core/Unify.hs-boot b/compiler/GHC/Core/Unify.hs-boot
new file mode 100644
index 0000000000..b08fcf83c9
--- /dev/null
+++ b/compiler/GHC/Core/Unify.hs-boot
@@ -0,0 +1,9 @@
+module GHC.Core.Unify where
+
+import GHC.Core.TyCo.Subst (Subst)
+import GHC.Core.Type (Type)
+
+
+import Data.Maybe (Maybe)
+
+tcMatchTys :: [Type] -> [Type] -> Maybe Subst
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 565bf698bc..020b956d8f 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -2385,9 +2385,9 @@ isEmptyTy ty
 normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
 normSplitTyConApp_maybe fam_envs ty
   | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty
-                           `orElse` (mkReflRedn Representational ty)
+                               `orElse` (mkReflRedn ty)
   , Just (tc, tc_args) <- splitTyConApp_maybe ty1
-  = Just (tc, tc_args, co)
+  = Just (tc, tc_args, mkHydrateDCo Representational ty co ty1)
 normSplitTyConApp_maybe _ _ = Nothing
 
 {-
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index e6d3fe93b7..9de8e84972 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -24,6 +24,7 @@ module GHC.CoreToIface
     , tidyToIfaceTcArgs
       -- * Coercions
     , toIfaceCoercion, toIfaceCoercionX
+    , toIfaceDCoercionX
       -- * Pattern synonyms
     , patSynToIfaceDecl
       -- * Expressions
@@ -275,10 +276,14 @@ toIfaceCoercion :: Coercion -> IfaceCoercion
 toIfaceCoercion = toIfaceCoercionX emptyVarSet
 
 toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
+toIfaceDCoercionX :: VarSet -> DCoercion -> IfaceDCoercion
 -- (toIfaceCoercionX free ty)
 --    translates the tyvars in 'free' as IfaceFreeTyVars
-toIfaceCoercionX fr co
-  = go co
+toIfaceCoercionX = fst . toIfaceCoercionDCoercion
+toIfaceDCoercionX = snd . toIfaceCoercionDCoercion
+
+toIfaceCoercionDCoercion :: VarSet -> (Coercion -> IfaceCoercion, DCoercion -> IfaceDCoercion)
+toIfaceCoercionDCoercion fr = (go, go_dco)
   where
     go_mco MRefl     = IfaceMRefl
     go_mco (MCo co)  = IfaceMCo $ go co
@@ -301,7 +306,8 @@ toIfaceCoercionX fr co
     go (SubCo co)           = IfaceSubCo (go co)
     go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)
     go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
-    go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov p) r
+    go (HydrateDCo r t dco _)= IfaceHydrateDCo r (toIfaceTypeX fr t) (go_dco dco)
+    go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov go p) r
                                           (toIfaceTypeX fr t1)
                                           (toIfaceTypeX fr t2)
     go co@(TyConAppCo r tc cos)
@@ -317,11 +323,34 @@ toIfaceCoercionX fr co
                           where
                             fr' = fr `delVarSet` tv
 
-    go_prov :: UnivCoProvenance -> IfaceUnivCoProv
-    go_prov (PhantomProv co)    = IfacePhantomProv (go co)
-    go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
-    go_prov (PluginProv str)    = IfacePluginProv str
-    go_prov (CorePrepProv b)    = IfaceCorePrepProv b
+
+    go_dco ReflDCo             = IfaceReflDCo
+    go_dco (GReflRightDCo co)  = IfaceGReflRightDCo (go co)
+    go_dco (GReflLeftDCo  co)  = IfaceGReflLeftDCo  (go co)
+    go_dco (CoVarDCo cv)
+      -- See [TcTyVars in IfaceType] in GHC.Iface.Type
+      | cv `elemVarSet` fr     = IfaceFreeCoVarDCo cv
+      | otherwise              = IfaceCoVarDCo (toIfaceCoVar cv)
+    go_dco (AppDCo co1 co2)    = IfaceAppDCo  (go_dco co1) (go_dco co2)
+    go_dco (TransDCo co1 co2)  = IfaceTransDCo (go_dco co1) (go_dco co2)
+    go_dco (AxiomInstDCo ax)   = IfaceAxiomInstDCo (coAxiomName ax)
+    go_dco (StepsDCo n)        = IfaceStepsDCo n
+    go_dco (TyConAppDCo cos)   = IfaceTyConAppDCo (map go_dco cos)
+    go_dco (SubDCo dco)        = IfaceSubDCo (go_dco dco)
+    go_dco (DehydrateCo co)    = IfaceDehydrateCo (go co)
+    go_dco (ForAllDCo tv k co) = IfaceForAllDCo (toIfaceBndr tv)
+                                                (toIfaceDCoercionX fr' k)
+                                                (toIfaceDCoercionX fr' co)
+                          where
+                            fr' = fr `delVarSet` tv
+
+    go_dco (UnivDCo p rhs)     = IfaceUnivDCo (go_prov go_dco p) (toIfaceTypeX fr rhs)
+
+    go_prov :: (co -> iface_co) -> UnivCoProvenance co -> IfaceUnivCoProv iface_co
+    go_prov to_iface (PhantomProv co)    = IfacePhantomProv (to_iface co)
+    go_prov to_iface (ProofIrrelProv co) = IfaceProofIrrelProv (to_iface co)
+    go_prov _        (PluginProv str)    = IfacePluginProv str
+    go_prov _        (CorePrepProv b)    = IfaceCorePrepProv b
 
 toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
 toIfaceTcArgs = toIfaceTcArgsX emptyVarSet
diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot
index 61b291f324..fbd7436651 100644
--- a/compiler/GHC/CoreToIface.hs-boot
+++ b/compiler/GHC/CoreToIface.hs-boot
@@ -1,8 +1,9 @@
 module GHC.CoreToIface where
 
-import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion, DCoercion )
 import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr
-                                    , IfaceCoercion, IfaceTyLit, IfaceAppArgs )
+                                    , IfaceCoercion, IfaceDCoercion
+                                    , IfaceTyLit, IfaceAppArgs )
 import GHC.Types.Var ( VarBndr, TyCoVar )
 import GHC.Types.Var.Env ( TidyEnv )
 import GHC.Core.TyCon ( TyCon )
@@ -15,4 +16,5 @@ toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag]
 toIfaceTyCon :: TyCon -> IfaceTyCon
 toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
 toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
+toIfaceDCoercionX :: VarSet -> DCoercion -> IfaceDCoercion
 tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs
index c92da902c9..b63a36335d 100644
--- a/compiler/GHC/Driver/Config.hs
+++ b/compiler/GHC/Driver/Config.hs
@@ -16,7 +16,15 @@ import GHCi.Message (EvalOpts(..))
 -- | Initialise coercion optimiser configuration from DynFlags
 initOptCoercionOpts :: DynFlags -> OptCoercionOpts
 initOptCoercionOpts dflags = OptCoercionOpts
-   { optCoercionEnabled = not (hasNoOptCoercion dflags)
+   { optCoercionOpts
+       = if hasNoOptCoercion dflags
+         then Nothing
+         else
+            let dco_method =
+                 if hasKeepDCoercions dflags
+                 then OptDCos { skipDCoOpt = True }
+                 else HydrateDCos
+            in Just dco_method
    }
 
 -- | Initialise Simple optimiser configuration from DynFlags
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 2099d7c100..813a723be0 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -472,6 +472,7 @@ data GeneralFlag
 
    | Opt_G_NoStateHack
    | Opt_G_NoOptCoercion
+   | Opt_G_KeepDCoercions
    deriving (Eq, Show, Enum)
 
 -- Check whether a flag should be considered an "optimisation flag"
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 84962f7868..150384670d 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -28,7 +28,8 @@ module GHC.Driver.Session (
         FatalMessager, FlushOut(..),
         ProfAuto(..),
         glasgowExtsFlags,
-        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,
+        hasPprDebug, hasNoDebugOutput, hasNoStateHack,
+        hasNoOptCoercion, hasKeepDCoercions,
         dopt, dopt_set, dopt_unset,
         gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',
         wopt, wopt_set, wopt_unset,
@@ -1467,6 +1468,8 @@ hasNoStateHack = gopt Opt_G_NoStateHack
 hasNoOptCoercion :: DynFlags -> Bool
 hasNoOptCoercion = gopt Opt_G_NoOptCoercion
 
+hasKeepDCoercions :: DynFlags -> Bool
+hasKeepDCoercions = gopt Opt_G_KeepDCoercions
 
 -- | Test whether a 'DumpFlag' is set
 dopt :: DumpFlag -> DynFlags -> Bool
@@ -2384,6 +2387,8 @@ dynamic_flags_deps = [
         (NoArg (setGeneralFlag Opt_G_NoStateHack))
   , make_ord_flag defGhcFlag "fno-opt-coercion"
         (NoArg (setGeneralFlag Opt_G_NoOptCoercion))
+  , make_ord_flag defGhcFlag "fkeep-dcoercions"
+        (NoArg (setGeneralFlag Opt_G_KeepDCoercions))
   , make_ord_flag defGhcFlag "with-rtsopts"
         (HasArg setRtsOpts)
   , make_ord_flag defGhcFlag "rtsopts"
@@ -4086,6 +4091,7 @@ optLevelFlags -- see Note [Documenting optimisation flags]
 
     , ([0],     Opt_IgnoreInterfacePragmas)
     , ([0],     Opt_OmitInterfacePragmas)
+    , ([0],     Opt_G_KeepDCoercions)
 
     , ([1,2],   Opt_CoreConstantFolding)
 
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index b372e7a1d9..b8e0992a3a 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -675,12 +675,14 @@ 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 (IfaceHydrateDCo r t1 dco)
+    = IfaceHydrateDCo r <$> rnIfaceType t1 <*> rnIfaceDCo dco
 rnIfaceCo (IfaceUnivCo s r t1 t2)
-    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
+    = IfaceUnivCo <$> rnIfaceProv rnIfaceCo s <*> pure r <*> rnIfaceType t1 <*> rnIfaceType t2
 rnIfaceCo (IfaceSymCo c)
     = IfaceSymCo <$> rnIfaceCo c
-rnIfaceCo (IfaceTransCo c1 c2)
-    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceTransCo co1 co2)
+    = IfaceTransCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
 rnIfaceCo (IfaceInstCo c1 c2)
     = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
 rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c
@@ -690,6 +692,42 @@ rnIfaceCo (IfaceAxiomRuleCo ax cos)
     = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
 rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
 
+rnIfaceDCo :: Rename IfaceDCoercion
+rnIfaceDCo IfaceReflDCo
+  = return IfaceReflDCo
+rnIfaceDCo (IfaceGReflRightDCo co)
+  = IfaceGReflRightDCo <$> rnIfaceCo co
+rnIfaceDCo (IfaceGReflLeftDCo  co)
+  = IfaceGReflLeftDCo  <$> rnIfaceCo co
+rnIfaceDCo (IfaceTyConAppDCo dcos)
+  = IfaceTyConAppDCo <$> mapM rnIfaceDCo dcos
+rnIfaceDCo (IfaceAppDCo dco1 dco2)
+  = IfaceAppDCo <$> rnIfaceDCo dco1 <*> rnIfaceDCo dco2
+rnIfaceDCo (IfaceForAllDCo bndr dco1 dco2)
+  = IfaceForAllDCo <$> rnIfaceBndr bndr <*> rnIfaceDCo dco1 <*> rnIfaceDCo dco2
+rnIfaceDCo (IfaceCoVarDCo lcl)
+  = return (IfaceCoVarDCo lcl)
+rnIfaceDCo (IfaceFreeCoVarDCo c)
+  = return (IfaceFreeCoVarDCo c)
+rnIfaceDCo (IfaceAxiomInstDCo ax)
+  = return (IfaceAxiomInstDCo ax)
+rnIfaceDCo (IfaceStepsDCo steps)
+  = return (IfaceStepsDCo steps)
+rnIfaceDCo (IfaceTransDCo co1 co2)
+  = IfaceTransDCo <$> rnIfaceDCo co1 <*> rnIfaceDCo co2
+rnIfaceDCo (IfaceDehydrateCo co)
+  = IfaceDehydrateCo <$> rnIfaceCo co
+rnIfaceDCo (IfaceUnivDCo prov rhs)
+  = IfaceUnivDCo <$> rnIfaceProv rnIfaceDCo prov <*> rnIfaceType rhs
+rnIfaceDCo (IfaceSubDCo dco)
+  = IfaceSubDCo <$> rnIfaceDCo dco
+
+rnIfaceProv :: Rename iface_co -> Rename (IfaceUnivCoProv iface_co)
+rnIfaceProv rn_thing (IfacePhantomProv    iface_co) = IfacePhantomProv    <$> rn_thing iface_co
+rnIfaceProv rn_thing (IfaceProofIrrelProv iface_co) = IfaceProofIrrelProv <$> rn_thing iface_co
+rnIfaceProv _        (IfacePluginProv str)          = return (IfacePluginProv str)
+rnIfaceProv _        (IfaceCorePrepProv homo)       = return (IfaceCorePrepProv homo)
+
 rnIfaceTyCon :: Rename IfaceTyCon
 rnIfaceTyCon (IfaceTyCon n info)
     = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 71b87cb19c..686cb187cf 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -1724,8 +1724,10 @@ freeNamesIfCoercion (IfaceCoVarCo _)   = emptyNameSet
 freeNamesIfCoercion (IfaceHoleCo _)    = emptyNameSet
 freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
   = unitNameSet ax &&& fnList freeNamesIfCoercion cos
+freeNamesIfCoercion (IfaceHydrateDCo _ t1 dco)
+  = freeNamesIfType t1 &&& freeNamesIfDCoercion dco
 freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
-  = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
+  = freeNamesIfProv freeNamesIfCoercion p &&& freeNamesIfType t1 &&& freeNamesIfType t2
 freeNamesIfCoercion (IfaceSymCo c)
   = freeNamesIfCoercion c
 freeNamesIfCoercion (IfaceTransCo c1 c2)
@@ -1744,11 +1746,33 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
   -- the axiom is just a string, so we don't count it as a name.
   = fnList freeNamesIfCoercion cos
 
-freeNamesIfProv :: IfaceUnivCoProv -> NameSet
-freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co
-freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
-freeNamesIfProv (IfacePluginProv _)      = emptyNameSet
-freeNamesIfProv (IfaceCorePrepProv _)    = emptyNameSet
+freeNamesIfDCoercion :: IfaceDCoercion -> NameSet
+freeNamesIfDCoercion IfaceReflDCo          = emptyNameSet
+freeNamesIfDCoercion (IfaceGReflRightDCo co)
+  = freeNamesIfCoercion co
+freeNamesIfDCoercion (IfaceGReflLeftDCo co)
+  = freeNamesIfCoercion co
+freeNamesIfDCoercion (IfaceTyConAppDCo cos)
+  = fnList freeNamesIfDCoercion cos
+freeNamesIfDCoercion (IfaceAppDCo c1 c2)
+  = freeNamesIfDCoercion c1 &&& freeNamesIfDCoercion c2
+freeNamesIfDCoercion (IfaceForAllDCo _ kind_co co)
+  = freeNamesIfDCoercion kind_co &&& freeNamesIfDCoercion co
+freeNamesIfDCoercion (IfaceFreeCoVarDCo _)  = emptyNameSet
+freeNamesIfDCoercion (IfaceCoVarDCo _)      = emptyNameSet
+freeNamesIfDCoercion (IfaceAxiomInstDCo ax) = unitNameSet ax
+freeNamesIfDCoercion IfaceStepsDCo{}        = emptyNameSet
+freeNamesIfDCoercion (IfaceTransDCo co1 co2)
+  = freeNamesIfDCoercion co1 &&& freeNamesIfDCoercion co2
+freeNamesIfDCoercion (IfaceDehydrateCo co) = freeNamesIfCoercion co
+freeNamesIfDCoercion (IfaceUnivDCo p rhs)  = freeNamesIfProv freeNamesIfDCoercion p &&& freeNamesIfType rhs
+freeNamesIfDCoercion (IfaceSubDCo dco) = freeNamesIfDCoercion dco
+
+freeNamesIfProv :: (co -> NameSet) -> IfaceUnivCoProv co -> NameSet
+freeNamesIfProv free_names (IfacePhantomProv co)    = free_names co
+freeNamesIfProv free_names (IfaceProofIrrelProv co) = free_names co
+freeNamesIfProv _          (IfacePluginProv _)      = emptyNameSet
+freeNamesIfProv _          (IfaceCorePrepProv _)    = emptyNameSet
 
 freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet
 freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 2b45a712e6..b43c285eac 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -19,6 +19,7 @@ module GHC.Iface.Type (
 
         IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
         IfaceMCoercion(..),
+        IfaceDCoercion(..),
         IfaceUnivCoProv(..),
         IfaceMult,
         IfaceTyCon(..),
@@ -53,6 +54,7 @@ module GHC.Iface.Type (
         pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll,
         pprIfaceSigmaType, pprIfaceTyLit,
         pprIfaceCoercion, pprParendIfaceCoercion,
+        pprIfaceDCoercion,
         splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
         pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
         isIfaceRhoType,
@@ -387,7 +389,8 @@ data 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 GHC.Builtin.Types.Literals
-  | IfaceUnivCo       IfaceUnivCoProv Role IfaceType IfaceType
+  | IfaceHydrateDCo   Role IfaceType IfaceDCoercion
+  | IfaceUnivCo       (IfaceUnivCoProv IfaceCoercion) Role IfaceType IfaceType
   | IfaceSymCo        IfaceCoercion
   | IfaceTransCo      IfaceCoercion IfaceCoercion
   | IfaceSelCo        CoSel IfaceCoercion
@@ -398,11 +401,27 @@ data IfaceCoercion
   | IfaceFreeCoVar    CoVar    -- See Note [Free tyvars in IfaceType]
   | IfaceHoleCo       CoVar    -- ^ See Note [Holes in IfaceCoercion]
 
-data IfaceUnivCoProv
-  = IfacePhantomProv IfaceCoercion
-  | IfaceProofIrrelProv IfaceCoercion
+data IfaceDCoercion
+  = IfaceReflDCo
+  | IfaceGReflRightDCo IfaceCoercion
+  | IfaceGReflLeftDCo  IfaceCoercion
+  | IfaceTyConAppDCo   [IfaceDCoercion]
+  | IfaceAppDCo        IfaceDCoercion IfaceDCoercion
+  | IfaceForAllDCo     IfaceBndr IfaceDCoercion IfaceDCoercion
+  | IfaceCoVarDCo      IfLclName
+  | IfaceFreeCoVarDCo  CoVar
+  | IfaceAxiomInstDCo  IfExtName
+  | IfaceStepsDCo      !Int
+  | IfaceTransDCo      IfaceDCoercion IfaceDCoercion
+  | IfaceDehydrateCo   IfaceCoercion
+  | IfaceSubDCo        IfaceDCoercion
+  | IfaceUnivDCo       (IfaceUnivCoProv IfaceDCoercion) IfaceType
+
+data IfaceUnivCoProv iface_co
+  = IfacePhantomProv iface_co
+  | IfaceProofIrrelProv iface_co
   | IfacePluginProv String
-  | IfaceCorePrepProv Bool  -- See defn of CorePrepProv
+  | IfaceCorePrepProv Bool            -- See defn of CorePrepProv
 
 {- Note [Holes in IfaceCoercion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -609,7 +628,8 @@ substIfaceType env ty
     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 (IfaceHydrateDCo r t1 dco) = IfaceHydrateDCo r (go t1) (go_dco dco)
+    go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov go_co prov) r (go t1) (go t2)
     go_co (IfaceSymCo co)            = IfaceSymCo (go_co co)
     go_co (IfaceTransCo co1 co2)     = IfaceTransCo (go_co co1) (go_co co2)
     go_co (IfaceSelCo n co)          = IfaceSelCo n (go_co co)
@@ -619,12 +639,28 @@ substIfaceType env ty
     go_co (IfaceSubCo co)            = IfaceSubCo (go_co co)
     go_co (IfaceAxiomRuleCo n cos)   = IfaceAxiomRuleCo n (go_cos cos)
 
+    go_dco IfaceReflDCo                = IfaceReflDCo
+    go_dco (IfaceGReflRightDCo co)     = IfaceGReflRightDCo (go_co co)
+    go_dco (IfaceGReflLeftDCo  co)     = IfaceGReflLeftDCo  (go_co co)
+    go_dco (IfaceTyConAppDCo cos)      = IfaceTyConAppDCo (go_dcos cos)
+    go_dco (IfaceAppDCo c1 c2)         = IfaceAppDCo (go_dco c1) (go_dco c2)
+    go_dco (IfaceForAllDCo {})         = pprPanic "substIfaceDCoercion" (ppr ty)
+    go_dco (IfaceFreeCoVarDCo cv)      = IfaceFreeCoVarDCo cv
+    go_dco (IfaceCoVarDCo cv)          = IfaceCoVarDCo cv
+    go_dco dco@IfaceAxiomInstDCo{}     = dco
+    go_dco dco@IfaceStepsDCo{}         = dco
+    go_dco (IfaceTransDCo co1 co2)     = IfaceTransDCo (go_dco co1) (go_dco co2)
+    go_dco (IfaceDehydrateCo co)       = IfaceDehydrateCo (go_co co)
+    go_dco (IfaceSubDCo dco)           = IfaceSubDCo (go_dco dco)
+    go_dco (IfaceUnivDCo p rhs)        = IfaceUnivDCo (go_prov go_dco p) (go rhs)
+
     go_cos = map go_co
+    go_dcos = map go_dco
 
-    go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)
-    go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
-    go_prov co@(IfacePluginProv _)   = co
-    go_prov co@(IfaceCorePrepProv _) = co
+    go_prov do_subst (IfacePhantomProv co)    = IfacePhantomProv    (do_subst co)
+    go_prov do_subst (IfaceProofIrrelProv co) = IfaceProofIrrelProv (do_subst co)
+    go_prov _        co@(IfacePluginProv _)   = co
+    go_prov _        co@(IfaceCorePrepProv _) = co
 
 substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs
 substIfaceAppArgs env args
@@ -1248,9 +1284,9 @@ 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 ]
+pprIfaceForAllCoPart :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc -> SDoc
+pprIfaceForAllCoPart ppr_iface_co tvs sdoc
+  = sep [ pprIfaceForAllCo ppr_iface_co tvs, sdoc ]
 
 ppr_iface_forall_part :: ShowForAllFlag
                       -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc
@@ -1287,12 +1323,12 @@ ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1
   | otherwise              = (all_bndrs, [])
 ppr_itv_bndrs [] _ = ([], [])
 
-pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
-pprIfaceForAllCo []  = empty
-pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
+pprIfaceForAllCo :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc
+pprIfaceForAllCo _            []  = empty
+pprIfaceForAllCo ppr_iface_co tvs = text "forall" <+> pprIfaceForAllCoBndrs ppr_iface_co tvs <> dot
 
-pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
-pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
+pprIfaceForAllCoBndrs :: (iface_co -> SDoc) -> [(IfLclName, iface_co)] -> SDoc
+pprIfaceForAllCoBndrs ppr_iface_co bndrs = hsep $ map (pprIfaceForAllCoBndr ppr_iface_co) bndrs
 
 pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
 pprIfaceForAllBndr bndr =
@@ -1306,9 +1342,9 @@ pprIfaceForAllBndr bndr =
     -- See Note [Suppressing binder signatures]
     suppress_sig = SuppressBndrSig False
 
-pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
-pprIfaceForAllCoBndr (tv, kind_co)
-  = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
+pprIfaceForAllCoBndr :: (iface_co -> SDoc) -> (IfLclName, iface_co) -> SDoc
+pprIfaceForAllCoBndr ppr_iface_co (tv, kind_co)
+  = parens (ppr tv <+> dcolon <+> ppr_iface_co kind_co)
 
 -- | Show forall flag
 --
@@ -1793,7 +1829,7 @@ ppr_co ctxt_prec (IfaceAppCo co1 co2)
     ppr_co funPrec co1 <+> pprParendIfaceCoercion co2
 ppr_co ctxt_prec co@(IfaceForAllCo {})
   = maybeParen ctxt_prec funPrec $
-    pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)
+    pprIfaceForAllCoPart pprIfaceCoercion tvs (pprIfaceCoercion inner_co)
   where
     (tvs, inner_co) = split_co co
 
@@ -1808,10 +1844,13 @@ ppr_co _ (IfaceFreeCoVar covar) = ppr covar
 ppr_co _ (IfaceCoVarCo covar)   = ppr covar
 ppr_co _ (IfaceHoleCo covar)    = braces (ppr covar)
 
+ppr_co ctxt_prec (IfaceHydrateDCo role ty1 dco)
+  = maybeParen ctxt_prec appPrec $
+    text "Hydrate" <+> (ppr role <+> ppr_ty appPrec ty1 <+> pprParendIfaceDCoercion dco)
 ppr_co _ (IfaceUnivCo prov role ty1 ty2)
   = text "Univ" <> (parens $
-      sep [ ppr role <+> pprIfaceUnivCoProv prov
-          , dcolon <+>  ppr ty1 <> comma <+> ppr ty2 ])
+      sep [ ppr role <+> pprIfaceUnivCoProv pprParendIfaceCoercion prov
+          , dcolon <+> ppr_ty appPrec ty1 <+> text "~" <+> ppr_ty appPrec ty2 ])
 
 ppr_co ctxt_prec (IfaceInstCo co ty)
   = maybeParen ctxt_prec appPrec $
@@ -1853,14 +1892,77 @@ ppr_role r = underscore <> pp_role
                     Phantom          -> char 'P'
 
 ------------------
-pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
-pprIfaceUnivCoProv (IfacePhantomProv co)
-  = text "phantom" <+> pprParendIfaceCoercion co
-pprIfaceUnivCoProv (IfaceProofIrrelProv co)
-  = text "irrel" <+> pprParendIfaceCoercion co
-pprIfaceUnivCoProv (IfacePluginProv s)
+pprIfaceDCoercion, pprParendIfaceDCoercion :: IfaceDCoercion -> SDoc
+pprIfaceDCoercion = ppr_dco topPrec
+pprParendIfaceDCoercion = ppr_dco appPrec
+
+ppr_dco :: PprPrec -> IfaceDCoercion -> SDoc
+ppr_dco _         IfaceReflDCo = text "Refl"
+ppr_dco ctxt_prec (IfaceGReflRightDCo co)
+  = maybeParen ctxt_prec appPrec $
+    text "GReflRight" <+> pprParendIfaceCoercion co
+ppr_dco ctxt_prec (IfaceGReflLeftDCo co)
+  = maybeParen ctxt_prec appPrec $
+    text "GReflLeft" <+> pprParendIfaceCoercion co
+ppr_dco ctxt_prec (IfaceTyConAppDCo cos)
+  = ppr_special_dco ctxt_prec (text "TyConApp") cos
+ppr_dco ctxt_prec (IfaceAppDCo co1 co2)
+  = maybeParen ctxt_prec appPrec $
+    ppr_dco funPrec co1 <+> pprParendIfaceDCoercion co2
+ppr_dco ctxt_prec co@(IfaceForAllDCo {})
+  = maybeParen ctxt_prec funPrec $
+    pprIfaceForAllCoPart pprIfaceDCoercion tvs (pprIfaceDCoercion inner_dco)
+  where
+    (tvs, inner_dco) = split_dco co
+
+    split_dco (IfaceForAllDCo (IfaceTvBndr (name, _)) kind_dco co')
+      = let (tvs, co'') = split_dco co' in ((name,kind_dco):tvs,co'')
+    split_dco (IfaceForAllDCo (IfaceIdBndr (_, name, _)) kind_dco co')
+      = let (tvs, co'') = split_dco co' in ((name,kind_dco):tvs,co'')
+    split_dco co' = ([], co')
+
+-- Why these two? See Note [Free tyvars in IfaceType]
+ppr_dco _ (IfaceFreeCoVarDCo covar) = ppr covar
+ppr_dco _ (IfaceCoVarDCo covar)     = ppr covar
+
+ppr_dco _         (IfaceAxiomInstDCo ax) = ppr ax
+ppr_dco ctxt_prec (IfaceStepsDCo n)
+  = maybeParen ctxt_prec appPrec $
+    text "Steps" <+> ppr n
+
+ppr_dco ctxt_prec (IfaceTransDCo co1 co2)
+    -- chain nested TransCo
+  = let ppr_trans (IfaceTransDCo c1 c2) = semi <+> ppr_dco topPrec c1 : ppr_trans c2
+        ppr_trans c                     = [semi <+> ppr_dco opPrec c]
+    in maybeParen ctxt_prec opPrec $
+        vcat (ppr_dco topPrec co1 : ppr_trans co2)
+ppr_dco ctxt_prec (IfaceDehydrateCo co)
+  = maybeParen ctxt_prec funPrec
+  $ text "Dehydrate" <+> pprParendIfaceCoercion co
+ppr_dco _ (IfaceUnivDCo prov rhs)
+  = text "UnivDCo" <> (parens $
+      sep [ pprIfaceUnivCoProv pprParendIfaceDCoercion prov
+          , dcolon <+> text "_ ~>" <+> ppr_ty appPrec rhs ])
+ppr_dco ctxt_prec (IfaceSubDCo dco)
+  = maybeParen ctxt_prec appPrec $
+    text "Sub" <+> ppr_dco appPrec dco
+
+-- AMG TODO: deduplicate some of the pretty-printing code
+ppr_special_dco :: PprPrec -> SDoc -> [IfaceDCoercion] -> SDoc
+ppr_special_dco ctxt_prec doc cos
+  = maybeParen ctxt_prec appPrec
+               (sep [doc, nest 4 (sep (map pprParendIfaceDCoercion cos))])
+
+
+------------------
+pprIfaceUnivCoProv :: (iface_co -> SDoc) -> IfaceUnivCoProv iface_co -> SDoc
+pprIfaceUnivCoProv ppr_co (IfacePhantomProv co)
+  = text "phantom" <+> ppr_co co
+pprIfaceUnivCoProv ppr_co (IfaceProofIrrelProv co)
+  = text "irrel" <+> ppr_co co
+pprIfaceUnivCoProv _ (IfacePluginProv s)
   = text "plugin" <+> doubleQuotes (text s)
-pprIfaceUnivCoProv (IfaceCorePrepProv _)
+pprIfaceUnivCoProv _ (IfaceCorePrepProv _)
   = text "CorePrep"
 
 -------------------
@@ -2154,6 +2256,11 @@ instance Binary IfaceCoercion where
           putByte bh 17
           put_ bh a
           put_ bh b
+  put_ bh (IfaceHydrateDCo r ty dco) = do
+          putByte bh 18
+          put_ bh r
+          put_ bh ty
+          put_ bh dco
   put_ _ (IfaceFreeCoVar cv)
        = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv)
   put_ _  (IfaceHoleCo cv)
@@ -2217,9 +2324,96 @@ instance Binary IfaceCoercion where
            17-> do a <- get bh
                    b <- get bh
                    return $ IfaceAxiomRuleCo a b
+           18-> do r <- get bh
+                   t <- get bh
+                   dco <- get bh
+                   return $ IfaceHydrateDCo r t dco
            _ -> panic ("get IfaceCoercion " ++ show tag)
 
-instance Binary IfaceUnivCoProv where
+instance Binary IfaceDCoercion where
+  put_ bh IfaceReflDCo = do
+          putByte bh 1
+  put_ bh (IfaceGReflLeftDCo a) = do
+          putByte bh 2
+          put_ bh a
+  put_ bh (IfaceGReflRightDCo a) = do
+          putByte bh 3
+          put_ bh a
+  put_ bh (IfaceTyConAppDCo a) = do
+          putByte bh 4
+          put_ bh a
+  put_ bh (IfaceAppDCo a b) = do
+          putByte bh 5
+          put_ bh a
+          put_ bh b
+  put_ bh (IfaceForAllDCo a b c) = do
+          putByte bh 6
+          put_ bh a
+          put_ bh b
+          put_ bh c
+  put_ bh (IfaceCoVarDCo a) = do
+          putByte bh 7
+          put_ bh a
+  put_ bh (IfaceAxiomInstDCo a) = do
+          putByte bh 8
+          put_ bh a
+  put_ bh (IfaceStepsDCo a) = do
+          putByte bh 10
+          put_ bh a
+  put_ bh (IfaceTransDCo a b) = do
+          putByte bh 11
+          put_ bh a
+          put_ bh b
+  put_ bh (IfaceDehydrateCo a) = do
+          putByte bh 12
+          put_ bh a
+  put_ bh (IfaceUnivDCo p rhs) = do
+          putByte bh 13
+          put_ bh p
+          put_ bh rhs
+  put_ bh (IfaceSubDCo dco) = do
+          putByte bh 14
+          put_ bh dco
+  put_ _ (IfaceFreeCoVarDCo cv)
+       = pprPanic "Can't serialise IfaceFreeCoVarDCo" (ppr cv)
+          -- See Note [Holes in IfaceCoercion]
+
+  get bh = do
+      tag <- getByte bh
+      case tag of
+           1 -> return IfaceReflDCo
+           2 -> do a <- get bh
+                   return $ IfaceGReflLeftDCo a
+           3 -> do a <- get bh
+                   return $ IfaceGReflRightDCo a
+           4 -> do a <- get bh
+                   return $ IfaceTyConAppDCo a
+           5 -> do a <- get bh
+                   b <- get bh
+                   return $ IfaceAppDCo a b
+           6 -> do a <- get bh
+                   b <- get bh
+                   c <- get bh
+                   return $ IfaceForAllDCo a b c
+           7 -> do a <- get bh
+                   return $ IfaceCoVarDCo a
+           8 -> do a <- get bh
+                   return $ IfaceAxiomInstDCo a
+           10-> do a <- get bh
+                   return $ IfaceStepsDCo a
+           11-> do a <- get bh
+                   b <- get bh
+                   return $ IfaceTransDCo a b
+           12 -> do a <- get bh
+                    return $ IfaceDehydrateCo a
+           13 -> do p <- get bh
+                    rhs <- get bh
+                    return $ IfaceUnivDCo p rhs
+           14 -> do dco <- get bh
+                    return $ IfaceSubDCo dco
+           _ -> panic ("get IfaceDCoercion " ++ show tag)
+
+instance Binary iface_co => Binary (IfaceUnivCoProv iface_co) where
   put_ bh (IfacePhantomProv a) = do
           putByte bh 1
           put_ bh a
@@ -2286,6 +2480,7 @@ instance NFData IfaceCoercion where
     IfaceCoVarCo f1 -> rnf f1
     IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
     IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2
+    IfaceHydrateDCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3
     IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4
     IfaceSymCo f1 -> rnf f1
     IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2
@@ -2297,7 +2492,24 @@ instance NFData IfaceCoercion where
     IfaceFreeCoVar f1 -> f1 `seq` ()
     IfaceHoleCo f1 -> f1 `seq` ()
 
-instance NFData IfaceUnivCoProv where
+instance NFData IfaceDCoercion where
+  rnf = \case
+    IfaceReflDCo -> ()
+    IfaceGReflRightDCo f1 -> rnf f1
+    IfaceGReflLeftDCo f1 -> rnf f1
+    IfaceTyConAppDCo f1 -> rnf f1
+    IfaceAppDCo f1 f2 -> rnf f1 `seq` rnf f2
+    IfaceForAllDCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3
+    IfaceCoVarDCo f1 -> rnf f1
+    IfaceAxiomInstDCo f1 -> rnf f1
+    IfaceStepsDCo f1 -> rnf f1
+    IfaceUnivDCo f1 f2 -> rnf f1 `seq` rnf f2
+    IfaceTransDCo f1 f2 -> rnf f1 `seq` rnf f2
+    IfaceDehydrateCo f1 -> rnf f1
+    IfaceFreeCoVarDCo f1 -> f1 `seq` ()
+    IfaceSubDCo f1 -> f1 `seq` ()
+
+instance NFData (IfaceUnivCoProv co) where
   rnf x = seq x ()
 
 instance NFData IfaceMCoercion where
diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot
index 9c10f29ed5..ae26e40f3c 100644
--- a/compiler/GHC/Iface/Type.hs-boot
+++ b/compiler/GHC/Iface/Type.hs-boot
@@ -1,6 +1,7 @@
 module GHC.Iface.Type
    ( IfaceType, IfaceTyCon, IfaceBndr
-   , IfaceCoercion, IfaceTyLit, IfaceAppArgs
+   , IfaceCoercion, IfaceDCoercion
+   , IfaceTyLit, IfaceAppArgs
    )
 where
 
@@ -14,4 +15,5 @@ data IfaceType
 data IfaceTyCon
 data IfaceTyLit
 data IfaceCoercion
+data IfaceDCoercion
 data IfaceBndr
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index e37f34ef46..8fafceeb6a 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1491,11 +1491,15 @@ tcIfaceCo = go
                                         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
-    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
+    go (IfaceHydrateDCo r t1 dco)= do { t1 <- tcIfaceType t1
+                                      ; dco <- tcIfaceDCo dco
+                                      ; return $ HydrateDCo r t1 dco (followDCo r t1 dco) }
+                                       -- SLD TODO: investigate perf impact here...
+                                       -- might be worth storing RHS in the interface file...
+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv go p <*> pure r
                                           <*> tcIfaceType t1 <*> tcIfaceType t2
     go (IfaceSymCo c)            = SymCo    <$> go c
-    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1
-                                            <*> go c2
+    go (IfaceTransCo co1 co2)    = TransCo <$> go co1 <*> go co2
     go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
                                             <*> go t2
     go (IfaceSelCo d c)          = do { c' <- go c
@@ -1511,11 +1515,34 @@ tcIfaceCo = go
     go_var :: FastString -> IfL CoVar
     go_var = tcIfaceLclId
 
-tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
-tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco
-tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
-tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str
-tcIfaceUnivCoProv (IfaceCorePrepProv b)     = return $ CorePrepProv b
+tcIfaceDCo :: IfaceDCoercion -> IfL DCoercion
+tcIfaceDCo = go
+  where
+    go IfaceReflDCo            = pure ReflDCo
+    go (IfaceGReflRightDCo co) = GReflRightDCo <$> tcIfaceCo co
+    go (IfaceGReflLeftDCo  co) = GReflLeftDCo <$> tcIfaceCo co
+    go (IfaceTyConAppDCo cs)   = TyConAppDCo <$> mapM go cs
+    go (IfaceAppDCo c1 c2)     = AppDCo <$> go c1 <*> go c2
+    go (IfaceForAllDCo tv k c) = do { k' <- tcIfaceDCo k
+                                    ; bindIfaceBndr tv $ \ tv' ->
+                                        ForAllDCo tv' k' <$> go c }
+    go (IfaceCoVarDCo n)       = CoVarDCo <$> go_var n
+    go (IfaceAxiomInstDCo ax)  = AxiomInstDCo <$> tcIfaceCoAxiom ax
+    go (IfaceStepsDCo n)       = pure $ StepsDCo n
+    go (IfaceTransDCo co1 co2) = TransDCo <$> go co1 <*> go co2
+    go (IfaceDehydrateCo co)   = DehydrateCo <$> tcIfaceCo co
+    go (IfaceUnivDCo prov rhs) = UnivDCo <$> tcIfaceUnivCoProv go prov <*> tcIfaceType rhs
+    go (IfaceSubDCo dco)       = SubDCo <$> go dco
+    go (IfaceFreeCoVarDCo c)   = pprPanic "tcIfaceDCo:IfaceFreeCoVarDCo" (ppr c)
+
+    go_var :: FastString -> IfL CoVar
+    go_var = tcIfaceLclId
+
+tcIfaceUnivCoProv :: (co -> IfL iface_co) -> IfaceUnivCoProv co -> IfL (UnivCoProvenance iface_co)
+tcIfaceUnivCoProv tc_co (IfacePhantomProv kco)    = PhantomProv <$> tc_co kco
+tcIfaceUnivCoProv tc_co (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tc_co kco
+tcIfaceUnivCoProv _     (IfacePluginProv str)     = return $ PluginProv str
+tcIfaceUnivCoProv _     (IfaceCorePrepProv b)     = return $ CorePrepProv b
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 31c42f86d6..b369b43c48 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -137,10 +137,10 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
       | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty
       , not (null bndrs)
       = do redn <- go role rec_nts inner_ty
-           return $ mkHomoForAllRedn bndrs redn
+           return $ mkHomoForAllRedn bndrs inner_ty redn
 
       | otherwise -- see Note [Don't recur in normaliseFfiType']
-      = return $ mkReflRedn role ty
+      = return $ mkReflRedn ty
 
     go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
               -> WriterT (Bag GlobalRdrElt) TcM Reduction
@@ -168,13 +168,13 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
                  Just gre ->
                    do { redn <- go role rec_nts' nt_rhs
                       ; tell (unitBag gre)
-                      ; return $ nt_co `mkTransRedn` redn } }
+                      ; return $ mkDehydrateCoercionRedn nt_co `mkTransRedn` redn } } -- AMG TODO
 
         | isFamilyTyCon tc              -- Expand open tycons
-        , Reduction co ty <- normaliseTcApp env role tc tys
-        , not (isReflexiveCo co)
+        , redn0@(Reduction dco ty) <- normaliseTcApp env role tc tys
+        , not (isReflexiveDCo role (mkTyConApp tc tys) dco ty)
         = do redn <- go role rec_nts ty
-             return $ co `mkTransRedn` redn
+             return $ redn0 `mkTransRedn` redn
 
         | otherwise
         = nothing -- see Note [Don't recur in normaliseFfiType']
@@ -184,12 +184,12 @@ normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
             = do { args <- unzipRedns <$>
                             zipWithM ( \ ty r -> go r rec_nts ty )
                                      tys (tyConRoleListX role tc)
-                 ; return $ mkTyConAppRedn role tc args }
+                 ; return $ mkTyConAppRedn tc args }
           nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
           nt_rhs = newTyConInstRhs tc tys
 
           ty      = mkTyConApp tc tys
-          nothing = return $ mkReflRedn role ty
+          nothing = return $ mkReflRedn ty
 
 checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
 checkNewtypeFFI rdr_env tc
@@ -252,7 +252,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
                                     , fd_fi = imp_decl }))
   = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $
     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-       ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
+       ; (redn@(Reduction _ norm_sig_ty), gres) <- normaliseFfiType sig_ty
        ; let
              -- Drop the foralls before inspecting the
              -- structure of the foreign type.
@@ -272,10 +272,12 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
        ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
           -- Can't use sig_ty here because sig_ty :: Type and
           -- we need HsType Id hence the undefined
-       ; let fi_decl = ForeignImport { fd_name = L nloc id
-                                     , fd_sig_ty = undefined
-                                     , fd_i_ext = mkSymCo norm_co
-                                     , fd_fi = imp_decl' }
+       ; let co = mkSymCo $ mkHydrateReductionDCoercion Representational sig_ty redn
+             fi_decl =
+               ForeignImport { fd_name = L nloc id
+                             , fd_sig_ty = undefined
+                             , fd_i_ext = co
+                             , fd_fi = imp_decl' }
        ; return (id, L dloc fi_decl, gres) }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 
@@ -411,7 +413,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe
     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
     rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
 
-    (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
+    (redn@(Reduction _ norm_sig_ty), gres) <- normaliseFfiType sig_ty
 
     spec' <- tcCheckFEType norm_sig_ty spec
 
@@ -428,7 +430,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_e_ext = norm_co
+                           , fd_e_ext = mkHydrateReductionDCoercion Representational sig_ty redn
                            , fd_fe = spec' }
            , gres)
 tcFExport d = pprPanic "tcFExport" (ppr d)
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index 5e2b523e4b..b5b4a71f50 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -529,6 +529,7 @@ tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
 
       | otherwise
       = NS_Done
+-- AMG TODO: refactor tcTopNormaliseNewTypeTF_maybe to just return count of steps taken?
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
index 49210cefa8..5e850c6441 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ b/compiler/GHC/Tc/Solver/Canonical.hs
@@ -1010,31 +1010,40 @@ the rewriter set. We check this with an assertion.
  -}
 
 
-rewriteEvidence rewriters old_ev (Reduction co new_pred) do_next
-  | isReflCo co -- See Note [Rewriting with Refl]
+rewriteEvidence rewriters old_ev (Reduction dco new_pred) do_next
+  | isReflDCo dco -- See Note [Rewriting with Refl]
   = assert (isEmptyRewriterSet rewriters) $
     do_next (setCtEvPredType old_ev new_pred)
 
 rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
-                (Reduction co new_pred) do_next
+                          (Reduction dco new_pred) do_next
   = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
-    do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
+    do { let
+          old_pred = ctEvPred ev
+          dco' = downgradeDCoToRepresentational (ctEvRole ev) old_pred dco new_pred
+          co   = mkHydrateDCo Representational old_pred dco' new_pred
+
+          -- mkEvCast optimises ReflCo
+          new_tm = mkEvCast (evId old_evar) co
+       ; new_ev <- newGivenEvVar loc (new_pred, new_tm)
        ; do_next new_ev }
-  where
-    -- mkEvCast optimises ReflCo
-    new_tm = mkEvCast (evId old_evar)
-                (downgradeRole Representational (ctEvRole ev) co)
 
 rewriteEvidence new_rewriters
                 ev@(CtWanted { ctev_dest = dest
                              , ctev_loc = loc
                              , ctev_rewriters = rewriters })
-                (Reduction co new_pred) do_next
+                (Reduction dco new_pred) do_next
   = do { mb_new_ev <- newWanted loc rewriters' new_pred
-       ; massert (coercionRole co == ctEvRole ev)
+       ; let
+          old_pred = ctEvPred ev
+          dco' = downgradeDCoToRepresentational (ctEvRole ev) old_pred dco new_pred
+          co   = mkHydrateDCo Representational old_pred dco' new_pred
+          -- NB: this call to mkHydrateDCo is OK, because of the invariant
+          -- on the LHS type stored in a Reduction. See Note [The Reduction type]
+          -- in GHC.Core.Reduction.
+
        ; setWantedEvTerm dest IsCoherent $
-            mkEvCast (getEvExpr mb_new_ev)
-                     (downgradeRole Representational (ctEvRole ev) (mkSymCo co))
+            (mkEvCast (getEvExpr mb_new_ev) (mkSymCo co))
        ; case mb_new_ev of
             Fresh  new_ev -> do_next new_ev
             Cached _      -> stopWith ev "Cached wanted" }
diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs
index 6bb894b8b4..95d7b56b1c 100644
--- a/compiler/GHC/Tc/Solver/Equality.hs
+++ b/compiler/GHC/Tc/Solver/Equality.hs
@@ -239,7 +239,8 @@ can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
   = -- Rewrite the two types and try again
     do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
        ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped
+                     (ps_ty1,redn1) (ps_ty2,redn2)
        ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2)
        ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
 
@@ -633,10 +634,12 @@ can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
          -- through newtypes is tantamount to using their constructors.
        ; recordUsedGREs gres
 
-       ; let redn1 = mkReduction co1 ty1'
+       ; let redn1 = mkReduction (mkDehydrateCo co1) ty1'
+             -- TODO: eliminate dehydration
+
 
        ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped
-                     redn1 (mkReflRedn Representational ps_ty2)
+                     (ty1, redn1) (ps_ty2,mkReflRedn ps_ty2)
 
        ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
 
@@ -712,11 +715,9 @@ canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
                                            , ppr ty1 <+> text "|>" <+> ppr co1
                                            , ppr ps_ty2 ])
        ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                      (mkGReflLeftRedn role ty1 co1)
-                      (mkReflRedn role ps_ty2)
+                      (mkCastTy ty1 co1, mkGReflLeftRedn ty1 co1)
+                      (ps_ty2, mkReflRedn ps_ty2)
        ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
-  where
-    role = eqRelRole eq_rel
 
 ------------------------
 canTyConApp :: CtEvidence -> EqRel
@@ -1304,7 +1305,8 @@ canEqFailure ev ReprEq ty1 ty2
             -- new equalities become available
        ; traceTcS "canEqFailure with ReprEq" $
          vcat [ ppr ev, ppr redn1, ppr redn2 ]
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped
+                     (ty1,redn1) (ty2,redn2)
        ; continueWith (mkIrredCt ReprEqReason new_ev) }
 
 -- | Call when canonicalizing an equality fails with utterly no hope.
@@ -1315,7 +1317,8 @@ canEqHardFailure ev ty1 ty2
   = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
        ; (redn1, rewriters1) <- rewriteForErrors ev ty1
        ; (redn2, rewriters2) <- rewriteForErrors ev ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
+       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped
+                     (ty1,redn1) (ty2,redn2)
        ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
 
 {-
@@ -1506,8 +1509,8 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
               -- Otherwise we might put something in the inert set that isn't inert
          then startAgainWith (mkNonCanonical ev)
          else
-    do { let lhs_redn = mkReflRedn role ps_xi1
-             rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co
+    do { let lhs_redn = mkReflRedn ps_xi1
+             rhs_redn = mkGReflRightRedn xi2 mb_sym_kind_co
              mb_sym_kind_co = case swapped of
                                 NotSwapped -> mkSymCo kind_co
                                 IsSwapped  -> kind_co
@@ -1515,7 +1518,8 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
        ; traceTcS "Hetero equality gives rise to kind equality"
            (ppr swapped $$
             ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])
-       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn
+       ; type_ev <- rewriteEqEvidence rewriters ev swapped
+                      (xi1,lhs_redn) (xi2,rhs_redn)
 
        ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co
        ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }}
@@ -1540,7 +1544,6 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
               ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) }
 
     xi1  = canEqLHSType lhs1
-    role = eqRelRole eq_rel
 
 canEqCanLHSHomo :: CtEvidence          -- lhs ~ rhs
                                        -- or, if swapped: rhs ~ lhs
@@ -1626,7 +1629,6 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
          else finish_without_swapping } }
   where
     sym_mco = mkSymMCo mco
-    role    = eqRelRole eq_rel
     lhs1_ty  = canEqLHSType lhs1
     lhs2_ty  = canEqLHSType lhs2
 
@@ -1639,9 +1641,10 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
     --      where grefl1 : lhs1 ~ lhs1 |> sym co
     --            grefl2 : lhs2 ~ lhs2 |> co
     finish_with_swapping
-      = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco
-                 lhs2_redn = mkGReflLeftMRedn  role lhs2_ty mco
-           ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn
+      = do { let lhs1_redn = mkGReflRightMRedn lhs1_ty sym_mco
+                 lhs2_redn = mkGReflLeftMRedn  lhs2_ty mco
+           ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+                       (lhs1_ty, lhs1_redn) (mkCastTyMCo lhs2_ty mco, lhs2_redn)
            ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
 
     put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq
@@ -1772,7 +1775,7 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
               -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
 
               | otherwise
-              -> tryIrredInstead reason ev eq_rel swapped lhs rhs ;
+              -> tryIrredInstead reason ev swapped lhs rhs ;
 
             PuOK _ rhs_redn ->
 
@@ -1783,10 +1786,11 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
          -- We unify alpha := Int, and set co := <Int>.  No need to
          -- swap to   co = sym co'
          --           co' = <Int>
-         new_ev <- if isReflCo (reductionCoercion rhs_redn)
+         new_ev <- if isReflDCo (reductionDCoercion rhs_redn)
                    then return ev
-                   else rewriteEqEvidence emptyRewriterSet ev swapped
-                            (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
+                   else let lhs = mkTyVarTy tv
+                            in rewriteEqEvidence emptyRewriterSet ev swapped
+                            (lhs, mkReflRedn lhs) (rhs, rhs_redn)
 
        ; let tv_ty     = mkTyVarTy tv
              final_rhs = reductionReducedType rhs_redn
@@ -1848,12 +1852,12 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
 --              -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs
 --              | otherwise
 
-              -> tryIrredInstead reason ev eq_rel swapped lhs rhs
+              -> tryIrredInstead reason ev swapped lhs rhs
 
             PuOK _ rhs_redn
               -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                                   (mkReflRedn (eqRelRole eq_rel) lhs_ty)
-                                   rhs_redn
+                                   (lhs_ty, mkReflRedn lhs_ty)
+                                   (rhs, rhs_redn)
 
                     -- Important: even if the coercion is Refl,
                     --   * new_ev has reductionReducedType on the RHS
@@ -1871,30 +1875,28 @@ swapAndFinish :: CtEvidence -> EqRel -> SwapFlag
 -- mentions alpha, it would not be a canonical constraint as-is.
 -- We want to flip it to (F tys ~ a), whereupon it is canonical
 swapAndFinish ev eq_rel swapped lhs_ty can_rhs
-  = do { new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped)
-                       (mkReflRedn role (canEqLHSType can_rhs))
-                       (mkReflRedn role lhs_ty)
+  = do { let rhs = canEqLHSType can_rhs
+       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped)
+                       (rhs, mkReflRedn rhs)
+                       (lhs_ty, mkReflRedn lhs_ty)
        ; interactEq (EqCt { eq_ev  = new_ev, eq_eq_rel = eq_rel
                           , eq_lhs = can_rhs, eq_rhs = lhs_ty }) }
-  where
-    role = eqRelRole eq_rel
 
 ----------------------
-tryIrredInstead :: CheckTyEqResult -> CtEvidence -> EqRel -> SwapFlag
+tryIrredInstead :: CheckTyEqResult -> CtEvidence -> SwapFlag
                 -> CanEqLHS -> TcType -> TcS (StopOrContinue Ct)
 -- We have a non-canonical equality
 -- We still swap it if 'swapped' says so, so that it is oriented
 -- in the direction that the error message reporting machinery
 -- expects it; e.g.  (m ~ t m) rather than (t m ~ m)
 -- This is not very important, and only affects error reporting.
-tryIrredInstead reason ev eq_rel swapped lhs rhs
+tryIrredInstead reason ev swapped lhs rhs
   = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs)
+       ; let lhs_ty = canEqLHSType lhs
        ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                       (mkReflRedn role (canEqLHSType lhs))
-                       (mkReflRedn role rhs)
+                       (lhs_ty, mkReflRedn lhs_ty)
+                       (rhs, mkReflRedn rhs)
        ; solveIrredEquality (NonCanonicalReason reason) new_ev }
-  where
-    role = eqRelRole eq_rel
 
 -----------------------
 -- | Solve a reflexive equality constraint
@@ -2386,8 +2388,8 @@ rewriteEqEvidence :: RewriterSet        -- New rewriters
                   -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
                                         --              or orhs ~ olhs (swapped)
                   -> SwapFlag
-                  -> Reduction          -- lhs_co :: olhs ~ nlhs
-                  -> Reduction          -- rhs_co :: orhs ~ nrhs
+                  -> (Type, Reduction)  -- lhs_co :: olhs ~ nlhs
+                  -> (Type, Reduction)  -- rhs_co :: orhs ~ nrhs
                   -> TcS CtEvidence     -- Of type nlhs ~ nrhs
 -- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),
 -- rewriteEqEvidence yields, for a given equality (Given g olhs orhs):
@@ -2404,10 +2406,11 @@ rewriteEqEvidence :: RewriterSet        -- New rewriters
 --      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co
 --
 -- It's all a form of rewriteEvidence, specialised for equalities
-rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)
+rewriteEqEvidence new_rewriters old_ev swapped (olhs, lhs_redn@(Reduction lhs_dco nlhs))
+                                               (orhs, rhs_redn@(Reduction rhs_dco nrhs))
   | NotSwapped <- swapped
-  , isReflCo lhs_co      -- See Note [Rewriting with Refl]
-  , isReflCo rhs_co
+  , isReflDCo lhs_dco      -- See Note [Rewriting with Refl]
+  , isReflDCo rhs_dco
   = return (setCtEvPredType old_ev new_pred)
 
   | CtGiven { ctev_evar = old_evar } <- old_ev
@@ -2437,6 +2440,8 @@ rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reductio
   where
     new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
     loc      = ctEvLoc old_ev
+    lhs_co = mkHydrateReductionDCoercion (ctEvRole old_ev) olhs lhs_redn
+    rhs_co = mkHydrateReductionDCoercion (ctEvRole old_ev) orhs rhs_redn
 
 {-
 **********************************************************************
@@ -2678,7 +2683,6 @@ final_qci_check work_ct eq_rel lhs rhs
   where
     ev  = ctEvidence work_ct
     loc = ctEvLoc ev
-    role = eqRelRole eq_rel
 
     try_for_qci  -- First try looking for (lhs ~ rhs)
        | Just (cls, tys) <- boxEqPred eq_rel lhs rhs
@@ -2698,7 +2702,7 @@ final_qci_check work_ct eq_rel lhs rhs
             ; case res of
                 OneInst { cir_mk_ev = mk_ev }
                   -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped
-                                      (mkReflRedn role rhs) (mkReflRedn role lhs)
+                                      (rhs, mkReflRedn rhs) (lhs, mkReflRedn lhs)
                         ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) }
                 _ -> do { traceTcS "final_qci_check:3" (ppr work_ct)
                         ; continueWith work_ct }}
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 91e20becf8..35d560f9a7 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -762,7 +762,8 @@ lookupFamAppInert rewrite_pred fam_tc tys
       | Just ecl <- findFunEq inert_funeqs fam_tc tys
       , Just (EqCt { eq_ev = ctev, eq_rhs = rhs })
           <- find (rewrite_pred . eqCtFlavourRole) ecl
-      = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev)
+      = Just (mkReduction (mkDehydrateCo (ctEvCoercion ctev)) rhs -- SLD TODO: avoid dehydrating?
+             ,ctEvFlavourRole ctev)
       | otherwise = Nothing
 
 lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
@@ -812,7 +813,6 @@ lookupFamAppCache fam_tc tys
            Nothing -> return Nothing }
 
 extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()
--- NB: co :: rhs ~ F tys, to match expectations of rewriter
 extendFamAppCache tc xi_args stuff@(Reduction _ ty)
   = do { dflags <- getDynFlags
        ; when (gopt Opt_FamAppCache dflags) $
@@ -831,7 +831,7 @@ dropFromFamAppCache varset
   where
     check :: Reduction -> Bool
     check redn
-      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)
+      = not (anyFreeVarsOfDCo (`elemVarSet` varset) $ reductionDCoercion redn)
 
 {- *********************************************************************
 *                                                                      *
@@ -892,16 +892,17 @@ data TcSEnv
 
 ---------------
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
-  deriving (Functor)
-
-instance MonadFix TcS where
-  mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env)
 
 -- | Smart constructor for 'TcS', as describe in Note [The one-shot state
 -- monad trick] in "GHC.Utils.Monad".
 mkTcS :: (TcSEnv -> TcM a) -> TcS a
 mkTcS f = TcS (oneShot f)
 
+-- Use the one-shot trick for the functor instance of 'TcS'.
+instance Functor TcS where
+  fmap f m = mkTcS $ \env ->
+    fmap f $ unTcS m env
+
 instance Applicative TcS where
   pure x = mkTcS $ \_ -> return x
   (<*>) = ap
@@ -913,6 +914,9 @@ instance Monad TcS where
 instance MonadIO TcS where
   liftIO act = TcS $ \_env -> liftIO act
 
+instance MonadFix TcS where
+  mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env)
+
 instance MonadFail TcS where
   fail err  = mkTcS $ \_ -> fail err
 
@@ -2103,7 +2107,7 @@ checkTouchableTyVarEq ev lhs_tv rhs
   | simpleUnifyCheck True lhs_tv rhs
     -- True <=> type families are ok on the RHS
   = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs)
-       ; return (pure (mkReflRedn Nominal rhs)) }
+       ; return (pure (mkReflRedn rhs)) }
 
   | otherwise
   = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs)
@@ -2165,8 +2169,8 @@ checkTouchableTyVarEq ev lhs_tv rhs
                                    , ctev_dest      = HoleDest hole
                                    , ctev_loc       = cb_loc
                                    , ctev_rewriters = ctEvRewriters ev }
-           ; return (PuOK (singleCt (mkNonCanonical new_ev))
-                          (mkReduction (HoleCo hole) new_tv_ty)) } }
+                 redn = mkDehydrateCoercionRedn (HoleCo hole)
+           ; return (PuOK (singleCt (mkNonCanonical new_ev)) redn) } }
 
     -- See Detail (7) of the Note
     cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
@@ -2231,7 +2235,7 @@ checkTypeEq ev eq_rel lhs rhs
     break_given fam_app
       = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app)
            ; return (PuOK (unitBag (new_tv, fam_app))
-                          (mkReflRedn Nominal (mkTyVarTy new_tv))) }
+                          (mkReflRedn (mkTyVarTy new_tv))) }
                     -- Why reflexive? See Detail (4) of the Note
 
     ---------------------------
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
index 64d590cbe9..6713019e35 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ b/compiler/GHC/Tc/Solver/Rewrite.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns  #-}
-
 {-# LANGUAGE DeriveFunctor #-}
 
 module GHC.Tc.Solver.Rewrite(
@@ -56,7 +55,10 @@ import qualified GHC.Data.List.Infinite as Inf
 -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv'
 newtype RewriteM a
   = RewriteM { runRewriteM :: RewriteEnv -> TcS a }
-  deriving (Functor)
+
+-- Use the one-shot trick for the functor instance of 'RewriteM'.
+instance Functor RewriteM where
+  fmap f m = mkRewriteM $ \env -> fmap f $ runRewriteM m env
 
 -- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state
 -- monad trick] in "GHC.Utils.Monad".
@@ -92,11 +94,11 @@ runRewriteCtEv ev
 runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet)
 runRewrite loc flav eq_rel thing_inside
   = do { rewriters_ref <- newTcRef emptyRewriterSet
-       ; let fmode = RE { re_loc  = loc
+       ; let rmode = RE { re_loc  = loc
                         , re_flavour = flav
                         , re_eq_rel = eq_rel
                         , re_rewriters = rewriters_ref }
-       ; res <- runRewriteM thing_inside fmode
+       ; res <- runRewriteM thing_inside rmode
        ; rewriters <- readTcRef rewriters_ref
        ; return (res, rewriters) }
 
@@ -212,16 +214,19 @@ a better error message anyway.)
 -}
 
 -- | See Note [Rewriting].
--- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty
+-- If (Reduction ty' dco xi, rewriters) <- rewrite mode ev ty, then dco :: ty' ~r xi
 -- where r is the role in @ev@.
--- rewriters is the set of coercion holes that have been used to rewrite
+-- @rewriters@ is the set of coercion holes that have been used to rewrite
 -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
 rewrite :: CtEvidence -> TcType
         -> TcS (Reduction, RewriterSet)
 rewrite ev ty
   = do { traceTcS "rewrite {" (ppr ty)
        ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty)
-       ; traceTcS "rewrite }" (ppr $ reductionReducedType redn)
+       ; traceTcS "rewrite }" $
+          vcat [ text "ty:" <+> ppr ty
+               , text "dco:" <+> ppr (reductionDCoercion redn)
+               , text "xi:" <+> ppr (reductionReducedType redn) ]
        ; return result }
 
 -- | See Note [Rewriting]
@@ -238,7 +243,7 @@ rewriteForErrors ev ty
        ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn)
        ; return $ case ctEvEqRel ev of
            NomEq -> result
-           ReprEq -> (mkSubRedn redn, rewriters) }
+           ReprEq -> (mkSubRedn ty redn, rewriters) }
 
 -- See Note [Rewriting]
 rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]
@@ -254,11 +259,11 @@ rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]
 -- Final return value returned which Wanteds rewrote another Wanted
 -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
 rewriteArgsNom ev tc tys
-  = do { traceTcS "rewrite_args {" (vcat (map ppr tys))
-       ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters)
+  = do { traceTcS "rewriteArgsNom {" (vcat (map ppr tys))
+       ; (ArgsReductions redns@(Reductions _ tys') kind_dco, rewriters)
            <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)
-       ; massert (isReflMCo kind_co)
-       ; traceTcS "rewrite }" (vcat (map ppr tys'))
+       ; massert (isReflMCo kind_dco)
+       ; traceTcS "rewriteArgsNom }" (vcat (map ppr tys'))
        ; return (redns, rewriters) }
 
 -- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite
@@ -282,16 +287,16 @@ rewriteType loc ty
 ********************************************************************* -}
 
 {- Note [Rewriting]
-~~~~~~~~~~~~~~~~~~~~
-  rewrite ty  ==>  Reduction co xi
+~~~~~~~~~~~~~~~~~~~
+  rewrite ty (at role r) ==> Reduction ty' dco xi
     where
       xi has no reducible type functions
          has no skolems that are mapped in the inert set
          has no filled-in metavariables
-      co :: ty ~ xi (coercions in reductions are always left-to-right)
+      dco :: ty' ~r xi (coercions in reductions are always left-to-right)
 
 Key invariants:
-  (F0) co :: zonk(ty') ~ xi   where zonk(ty') ~ zonk(ty)
+  (F0) dco :: zonk(ty') ~ xi   where zonk(ty') ~ zonk(ty)
   (F1) typeKind(xi) succeeds and returns a fully zonked kind
   (F2) typeKind(xi) `eqType` zonk(typeKind(ty))
 
@@ -301,18 +306,11 @@ Rewriting also:
   * zonks, removing any metavariables, and
   * applies the substitution embodied in the inert set
 
-Because rewriting zonks and the returned coercion ("co" above) is also
-zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead,
+Because rewriting zonks and the returned directed coercion ("dco" above)
+is also zonked, it's possible that (dco :: ty ~r xi) isn't quite true. So, instead,
 we can rely on this fact:
 
-  (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty)
-
-Note that the right-hand type of co is *always* precisely xi. The left-hand
-type may or may not be ty, however: if ty has unzonked filled-in metavariables,
-then the left-hand type of co will be the zonk-equal to ty.
-It is for this reason that we occasionally have to explicitly zonk,
-when (co :: ty ~ xi) is important even before we zonk the whole program.
-For example, see the RTRNotFollowed case in rewriteTyVar.
+  (F0) dco :: ty' ~r xi, where zonk(ty') ~ zonk(ty)
 
 Why have these invariants on rewriting? Because we sometimes use typeKind
 during canonicalisation, and we want this kind to be zonked (e.g., see
@@ -389,7 +387,7 @@ rewrite_args_tc
                    -- Otherwise: no assumptions; use roles provided
   -> [Type]
   -> RewriteM ArgsReductions -- See the commentary on rewrite_args
-rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet
+rewrite_args_tc tc roles args = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet roles args
   -- NB: TyCon kinds are always closed
   where
   -- There are many bang patterns in here. It's been observed that they
@@ -459,7 +457,12 @@ rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet
                   -> RewriteM ArgsReductions
 rewrite_args_slow binders inner_ki fvs roles tys
   = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys
-       ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }
+         -- NB: this is the crucial place where we require the hydration invariant
+         -- to be satisfied. This is achieved by having Reduction store a LHS type.
+         -- See Note [The Reduction type] in GHC.Core.Reduction,
+         -- and Note [Following a directed coercion] in GHC.Core.Coercion.
+         -- Relevant test case: T13333.
+       ; return $ simplifyArgsWorker binders inner_ki fvs roles tys rewritten_args }
   where
     {-# INLINE rw #-}
     rw :: Role -> Type -> RewriteM Reduction
@@ -474,7 +477,7 @@ rewrite_args_slow binders inner_ki fvs roles tys
     rw Phantom ty
     -- See Note [Phantoms in the rewriter]
       = do { ty <- liftTcS $ zonkTcType ty
-           ; return $ mkReflRedn Phantom ty }
+           ; return $ mkReflRedn ty }
 
 ------------------
 rewrite_one :: TcType -> RewriteM Reduction
@@ -490,8 +493,7 @@ rewrite_one ty
   = rewrite_one ty'
 
 rewrite_one xi@(LitTy {})
-  = do { role <- getRole
-       ; return $ mkReflRedn role xi }
+  = return $ mkReflRedn xi
 
 rewrite_one (TyVarTy tv)
   = rewriteTyVar tv
@@ -518,28 +520,34 @@ rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
        ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)
              res_rep = getRuntimeRep (reductionReducedType res_redn)
 
-       ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $
-           liftA3 (,,) (rewrite_one mult)
-                       (rewrite_one arg_rep)
-                       (rewrite_one res_rep)
-       ; role <- getRole
+       ; ( w_redn
+         , Reduction arg_rep_dco arg_rep_xi
+         , Reduction res_rep_dco res_rep_xi
+         ) <- setEqRel NomEq $
+                liftA3 (,,) (rewrite_one mult)
+                            (rewrite_one arg_rep)
+                            (rewrite_one res_rep)
 
-       ; let arg_rep_co = reductionCoercion arg_rep_redn
+       ; let arg_rep_co = mkHydrateDCo Nominal arg_rep arg_rep_dco arg_rep_xi
                 -- :: arg_rep ~ arg_rep_xi
              arg_ki_co  = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]
                 -- :: TYPE arg_rep ~ TYPE arg_rep_xi
-             casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co
+             casted_arg_redn = mkCoherenceRightRedn arg_redn arg_ki_co
                 -- :: ty1 ~> arg_xi |> arg_ki_co
 
-             res_rep_co = reductionCoercion res_rep_redn
+             res_rep_co = mkHydrateDCo Nominal res_rep res_rep_dco res_rep_xi
              res_ki_co  = mkTyConAppCo Nominal tYPETyCon [res_rep_co]
-             casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co
+             casted_res_redn = mkCoherenceRightRedn res_redn res_ki_co
+
+             -- NB: these two calls to mkHydrateDCo are OK, because of the invariant
+             -- on the LHS type stored in a Reduction. See Note [The Reduction type]
+             -- in GHC.Core.Reduction.
 
           -- We must rewrite the representations, because that's what would
           -- be done if we used TyConApp instead of FunTy. These rewritten
           -- representations are seen only in casts of the arg and res, below.
           -- Forgetting this caused #19677.
-       ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn }
+       ; return $ mkFunRedn vis w_redn arg_rep_dco res_rep_dco casted_arg_redn casted_res_redn }
 
 rewrite_one ty@(ForAllTy {})
 -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of
@@ -550,13 +558,12 @@ rewrite_one ty@(ForAllTy {})
 -- applications inside the forall involve the bound type variables.
   = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty
        ; redn <- rewrite_one rho
-       ; return $ mkHomoForAllRedn bndrs redn }
+       ; return $ mkHomoForAllRedn bndrs rho redn }
 
 rewrite_one (CastTy ty g)
   = do { redn <- rewrite_one ty
        ; g'   <- rewrite_co g
-       ; role <- getRole
-       ; return $ mkCastRedn1 role ty g' redn }
+       ; return $ mkCastRedn1 g' redn }
       -- This calls castCoercionKind1.
       -- It makes a /big/ difference to call castCoercionKind1 not
       -- the more general castCoercionKind2.
@@ -564,8 +571,7 @@ rewrite_one (CastTy ty g)
 
 rewrite_one (CoercionTy co)
   = do { co' <- rewrite_co co
-       ; role <- getRole
-       ; return $ mkReflCoRedn role co' }
+       ; return $ mkReflCoRedn co' }
 
 -- | "Rewrite" a coercion. Really, just zonk it so we can uphold
 -- (F1) of Note [Rewriting]
@@ -574,9 +580,9 @@ rewrite_co co = liftTcS $ zonkCo co
 
 -- | Rewrite a reduction, composing the resulting coercions.
 rewrite_reduction :: Reduction -> RewriteM Reduction
-rewrite_reduction (Reduction co xi)
+rewrite_reduction redn0@(Reduction _ xi)
   = do { redn <- bumpDepth $ rewrite_one xi
-       ; return $ co `mkTransRedn` redn }
+       ; return $ redn0 `mkTransRedn` redn }
 
 -- rewrite (nested) AppTys
 rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction
@@ -598,44 +604,38 @@ rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction
 rewrite_app_ty_args redn []
   -- this will be a common case when called from rewrite_fam_app, so shortcut
   = return redn
-rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
-  = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of
-           Just (tc, xis) ->
-             do { let tc_roles  = tyConRolesRepresentational tc
-                      arg_roles = Inf.dropList xis tc_roles
-                ; ArgsReductions (Reductions arg_cos arg_xis) kind_co
-                    <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys
-
-                  -- We start with a reduction of the form
-                  --   fun_co :: ty ~ T xi_1 ... xi_n
-                  -- and further arguments a_1, ..., a_m.
-                  -- We rewrite these arguments, and obtain coercions:
-                  --   arg_co_i :: a_i ~ zeta_i
-                  -- Now, 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:
-                  -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m
-                ; eq_rel <- getEqRel
-                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
-                      app_co = case eq_rel of
-                        NomEq  -> mkAppCos fun_co arg_cos
-                        ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)
-                                  `mkTransCo`
-                                  mkTyConAppCo Representational tc
-                                    (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos)
-
-                ; return $
-                    mkHetReduction
-                      (mkReduction app_co app_xi )
-                      kind_co }
-           Nothing ->
-             do { ArgsReductions redns kind_co
-                    <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys
-                ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }
-
-       ; role <- getRole
-       ; return (homogeniseHetRedn role het_redn) }
+rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) more_arg_tys
+  = case tcSplitTyConApp_maybe fun_xi of
+      Just (tc, xis) ->
+        do { let tc_roles  = tyConRolesRepresentational tc
+                 arg_roles = Inf.dropList xis tc_roles
+           ; ArgsReductions (Reductions arg_cos arg_xis) kind_co
+               <- rewrite_vector (typeKind fun_xi) arg_roles more_arg_tys
+
+             -- We start with a reduction of the form
+             --   fun_co :: ty ~ T xi_1 ... xi_n
+             -- and further arguments a_1, ..., a_m.
+             -- We rewrite these arguments, and obtain coercions:
+             --   arg_co_i :: a_i ~ zeta_i
+             -- Now, 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:
+             -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m
+
+           ; eq_rel <- getEqRel
+           ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
+                 app_co = case eq_rel of
+                   NomEq  -> mkAppDCos fun_co arg_cos
+                   ReprEq -> mkAppDCos fun_co (mkReflDCos more_arg_tys)
+                             `mkTransDCo`
+                             mkTyConAppDCo (mkReflDCos xis ++ arg_cos)
+
+           ; return $ homogeniseRedn (mkReduction app_co app_xi) kind_co }
+      Nothing ->
+        do { ArgsReductions redns kind_co
+               <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) more_arg_tys
+           ; return $ homogeniseRedn (mkAppRedns fun_redn redns) kind_co }
 
 rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction
 rewrite_ty_con_app tc tys
@@ -643,11 +643,10 @@ rewrite_ty_con_app tc tys
        ; let m_roles | Nominal <- role = Nothing
                      | otherwise       = Just $ tyConRolesX role tc
        ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys
-       ; let tyconapp_redn
-                = mkHetReduction
-                    (mkTyConAppRedn role tc redns)
-                    kind_co
-       ; return $ homogeniseHetRedn role tyconapp_redn }
+       ; return $ homogeniseRedn
+                    (mkTyConAppRedn_MightBeSynonym role tc tys redns)
+                    kind_co }
+{-# INLINE rewrite_ty_con_app #-}
 
 -- Rewrite a vector (list of arguments).
 rewrite_vector :: Kind   -- of the function being applied to these arguments
@@ -758,8 +757,8 @@ STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.)
 FINISH 1. We've made a reduction, but the new type may still have more
   work to do. So rewrite the new type.
 
-FINISH 2. Add the result to the famapp-cache, connecting the type we started
-  with to the one we ended with.
+FINISH 2. Add the result to the famapp-cache, to speed things up next time we
+  come across the same type family application.
 
 Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into
 try_to_reduce.
@@ -773,7 +772,6 @@ is inlined in that case, and only FINISH 1 is performed.
 rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction
   --   rewrite_fam_app            can be over-saturated
   --   rewrite_exact_fam_app      lifts out the application to top level
-  -- Postcondition: Coercion :: Xi ~ F tys
 rewrite_fam_app tc tys  -- Can be over-saturated
     = assertPpr (tys `lengthAtLeast` tyConArity tc)
                 (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $
@@ -782,15 +780,17 @@ rewrite_fam_app tc tys  -- Can be over-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
-         ; redn <- rewrite_exact_fam_app tc tys1
+      do { let (!tys1, !tys_rest)
+                 | length tys > tyConArity tc = splitAt (tyConArity tc) tys
+                 | otherwise = (tys, [])
+         ; !redn <- rewrite_exact_fam_app tc tys1
          ; rewrite_app_ty_args redn tys_rest }
 
 -- the [TcType] exactly saturate the TyCon
 -- See Note [How to normalise a family application]
 rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction
 rewrite_exact_fam_app tc tys
-  = do { checkStackDepth (mkTyConApp tc tys)
+  = do { checkStackDepth $ mkTyConApp tc tys
 
        -- Query the typechecking plugins for all their rewriting functions
        -- which apply to a type family application headed by the TyCon 'tc'.
@@ -801,17 +801,12 @@ rewrite_exact_fam_app tc tys
        ; case result1 of
              -- Don't use the cache;
              -- See Note [rewrite_exact_fam_app performance]
-         { Just redn -> finish False redn
+         { Just redn -> finish Don'tAddToCache redn
          ; Nothing ->
 
         -- That didn't work. So reduce the arguments, in STEP 2.
-    do { eq_rel <- getEqRel
-          -- checking eq_rel == NomEq saves ~0.5% in T9872a
-       ; ArgsReductions (Reductions cos xis) kind_co <-
-            if eq_rel == NomEq
-            then rewrite_args_tc tc Nothing tys
-            else setEqRel NomEq $
-                 rewrite_args_tc tc Nothing tys
+    do { (ArgsReductions redns@(Reductions _ xis) kind_co) <-
+            setEqRel NomEq $ rewrite_args_tc tc Nothing tys
 
          -- If we manage to rewrite the type family application after
          -- rewriting the arguments, we will need to compose these
@@ -826,63 +821,86 @@ rewrite_exact_fam_app tc tys
          --
          --   full_co :: F ty_1 ... ty_n ~ zeta
          --   full_co = F co_1 ... co_n ;; fam_co
-       ; let
-           role    = eqRelRole eq_rel
-           args_co = mkTyConAppCo role tc cos
-       ;  let homogenise :: Reduction -> Reduction
-              homogenise redn
-                = homogeniseHetRedn role
-                $ mkHetReduction
-                    (args_co `mkTransRedn` redn)
-                    kind_co
-
-              give_up :: Reduction
-              give_up = homogenise $ mkReflRedn role reduced
-                where reduced = mkTyConApp tc xis
+       ; let args_redn :: Reduction
+             !args_redn = mkTyConAppRedn tc redns
+             homogenise :: Reduction -> Reduction
+             homogenise redn
+               = homogeniseRedn
+                   (args_redn `mkTransRedn` redn)
+                   kind_co
+
+             give_up :: Reduction
+             give_up = homogenise $ mkReflRedn reduced
+               where reduced = mkTyConApp tc xis
 
          -- STEP 3: try the inerts
-       ; flavour <- getFlavour
-       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis
+       ; flavour_role@(_, eq_rel) <- getFlavourRole
+       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` flavour_role) tc xis
        ; case result2 of
-         { Just (redn, (inert_flavour, inert_eq_rel))
-             -> do { traceRewriteM "rewrite family application with inert"
-                                (ppr tc <+> ppr xis $$ ppr redn)
-                   ; finish (inert_flavour == Given) (homogenise downgraded_redn) }
-               -- this will sometimes duplicate an inert in the cache,
-               -- but avoiding doing so had no impact on performance, and
-               -- it seems easier not to weed out that special case
+         { Just (redn, (inert_flavour, inert_eq_rel)) ->
+            do { traceRewriteM "rewrite family application with inert" $
+                   ( ppr tc <+> ppr xis $$ ppr redn)
+               ; let use_cache :: AddToCache
+                     !use_cache
+                       -- Don't add something to the cache if the reduction
+                       -- contains a coercion hole.
+                       | inert_flavour == Given
+                       = RewroteArgsAddToCache
+                       | otherwise
+                       = Don'tAddToCache
+               ; finish use_cache (homogenise downgraded_redn) }
              where
                inert_role      = eqRelRole inert_eq_rel
                role            = eqRelRole eq_rel
-               downgraded_redn = downgradeRedn role inert_role redn
+               !downgraded_redn
+                 | inert_role == Nominal && role == Representational
+                 = mkSubRedn (mkTyConApp tc xis) redn
+                 | otherwise
+                 = redn
 
          ; _ ->
 
          -- inerts didn't work. Try to reduce again, in STEP 4.
     do { result3 <- try_to_reduce tc xis tc_rewriters
        ; case result3 of
-           Just redn -> finish True (homogenise redn)
+           Just redn -> finish RewroteArgsAddToCache (homogenise redn)
            -- we have made no progress at all: STEP 5 (GIVEUP).
            _         -> return give_up }}}}}
   where
       -- call this if the above attempts made progress.
       -- This recursively rewrites the result and then adds to the cache
-    finish :: Bool  -- add to the cache?
-                    -- Precondition: True ==> input coercion has
-                    --                        no coercion holes
-           -> Reduction -> RewriteM Reduction
+    finish :: AddToCache -- Add to the cache?
+           -> Reduction  -- Precondition: we can only add to the cache a 'Reduction'
+                         -- which does not have any coercion holes.
+           -> RewriteM Reduction
     finish use_cache redn
       = do { -- rewrite the result: FINISH 1
              final_redn <- rewrite_reduction redn
-           ; eq_rel <- getEqRel
-
+           ; case use_cache of
+           { Don'tAddToCache {} -> return final_redn
+           ; RewroteArgsAddToCache ->
              -- extend the cache: FINISH 2
-           ; when (use_cache && eq_rel == NomEq) $
-             -- the cache only wants Nominal eqs
-             liftTcS $ extendFamAppCache tc tys final_redn
-           ; return final_redn }
+        do { eq_rel <- getEqRel
+           ; when (eq_rel == NomEq) $
+               -- the cache only wants Nominal eqs
+               liftTcS $ extendFamAppCache tc tys final_redn
+                 -- This will sometimes duplicate an inert in the cache,
+                 -- but avoiding doing so had no impact on performance, and
+                 -- it seems easier not to weed out that special case.
+           ; return final_redn } } }
     {-# INLINE finish #-}
 
+-- | How to finish rewriting an exact type family application,
+-- depending on whether we have rewritten the arguments or not.
+data AddToCache
+  -- | We didn't rewrite the arguments: don't add to the cache.
+  --
+  -- See Note [rewrite_exact_fam_app performance].
+  = Don'tAddToCache
+  -- | We rewrote the arguments. We add the type family application,
+  -- with rewritten arguments, to the cache.
+  | RewroteArgsAddToCache
+
 -- Returned coercion is input ~r output, where r is the role in the RewriteM monad
 -- See Note [How to normalise a family application]
 try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter]
@@ -894,23 +912,23 @@ try_to_reduce tc tys tc_rewriters
               [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a
               , lookupFamAppCache tc tys                          -- STEP 1b & STEP 4b
               , matchFam tc tys ]                                 -- STEP 1c & STEP 4c
-       ; traverse downgrade result }
+       ; traverse finish result }
   where
     -- The result above is always Nominal. We might want a Representational
     -- coercion; this downgrades (and prints, out of convenience).
-    downgrade :: Reduction -> RewriteM Reduction
-    downgrade redn
+    finish :: Reduction -> RewriteM Reduction
+    finish redn
       = do { traceRewriteM "Eager T.F. reduction success" $
-             vcat [ ppr tc
-                  , ppr tys
-                  , ppr redn
-                  ]
+               vcat [ ppr tc
+                    , ppr tys
+                    , ppr redn
+                    ]
            ; eq_rel <- getEqRel
               -- manually doing it this way avoids allocation in the vastly
               -- common NomEq case
            ; case eq_rel of
                NomEq  -> return redn
-               ReprEq -> return $ mkSubRedn redn }
+               ReprEq -> return $ mkSubRedn (mkTyConApp tc tys) redn }
 
 -- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application
 -- headed by the given 'TyCon`.
@@ -959,11 +977,17 @@ runTcPluginRewriters rewriteEnv rewriterFunctions tys
 -- | The result of rewriting a tyvar "one step".
 data RewriteTvResult
   = RTRNotFollowed
-      -- ^ The inert set doesn't make the tyvar equal to anything else
+      -- ^ Not a filled metavariable, and the inert set doesn't make
+      -- the tyvar equal to anything else.
 
-  | RTRFollowed !Reduction
-      -- ^ The tyvar rewrites to a not-necessarily rewritten other type.
-      -- The role is determined by the RewriteEnv.
+  | RTRFollowedMeta !TcType
+      -- ^ We followed a filled metavariable to the given type,
+      -- which has not yet been rewritten.
+
+  | RTRFollowedInert !Reduction
+      -- ^ The tyvar rewrites to a not-necessarily rewritten other type,
+      -- using an inert equality; this rewriting is stored in a
+      -- 'Reduction'.
       --
       -- With Quick Look, the returned TcType can be a polytype;
       -- that is, in the constraint solver, a unification variable
@@ -974,14 +998,13 @@ rewriteTyVar :: TyVar -> RewriteM Reduction
 rewriteTyVar tv
   = do { mb_yes <- rewrite_tyvar1 tv
        ; case mb_yes of
-           RTRFollowed redn -> rewrite_reduction redn
-
+           RTRFollowedMeta  ty   -> rewrite_one ty
+           RTRFollowedInert redn -> rewrite_reduction redn
            RTRNotFollowed   -- Done, but make sure the kind is zonked
                             -- Note [Rewriting] invariant (F0) and (F1)
              -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv
-                   ; role <- getRole
                    ; let ty' = mkTyVarTy tv'
-                   ; return $ mkReflRedn role ty' } }
+                   ; return $ mkReflRedn ty' } }
 
 rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult
 -- "Rewriting" a type variable means to apply the substitution to it
@@ -995,9 +1018,7 @@ rewrite_tyvar1 tv
        ; case mb_ty of
            Just ty -> do { traceRewriteM "Following filled tyvar"
                              (ppr tv <+> equals <+> ppr ty)
-                         ; role <- getRole
-                         ; return $ RTRFollowed $
-                             mkReflRedn role ty }
+                         ; return $ RTRFollowedMeta ty }
            Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv)
                          ; fr <- getFlavourRole
                          ; rewrite_tyvar2 tv fr } }
@@ -1022,20 +1043,21 @@ rewrite_tyvar2 tv fr@(_, eq_rel)
                              , text "wanted_rewrite_wanted:" <+> ppr wrw ]
                    ; when wrw $ recordRewriter ctev
 
-                   ; let rewriting_co1 = ctEvCoercion ctev
-                         rewriting_co  = case (ct_eq_rel, eq_rel) of
+                   ; let rewriting_dco1 = mkDehydrateCo $ ctEvCoercion ctev
+                         rewriting_dco  = case (ct_eq_rel, eq_rel) of
                             (ReprEq, _rel)  -> assert (_rel == ReprEq)
                                     -- if this assert fails, then
                                     -- eqCanRewriteFR answered incorrectly
-                                               rewriting_co1
-                            (NomEq, NomEq)  -> rewriting_co1
-                            (NomEq, ReprEq) -> mkSubCo rewriting_co1
+                                               rewriting_dco1
+                            (NomEq, NomEq)  -> rewriting_dco1
+                            (NomEq, ReprEq) -> mkSubDCo lhs_ty rewriting_dco1 rhs_ty
 
-                   ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty }
+                    ; return $ RTRFollowedInert $ mkReduction rewriting_dco rhs_ty }
 
            _other -> return RTRNotFollowed }
-
   where
+    lhs_ty :: TcType
+    lhs_ty = mkTyVarTy tv
     can_rewrite :: EqCt -> Bool
     can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr
       -- This is THE key call of eqCanRewriteFR
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 8e7b3b8c39..56d6710872 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -40,7 +40,7 @@ import GHC.Builtin.Uniques ( mkBuiltinUnique )
 
 import GHC.Hs
 
-import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
+import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), DCoercion(..), UnivCoProvenance(..) )
 import GHC.Core.Multiplicity
 import GHC.Core.Predicate
 import GHC.Core.Make( rEC_SEL_ERROR_ID )
@@ -143,7 +143,8 @@ synonymTyConsOfType ty
      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 (HydrateDCo _ ty dco _)= go ty `plusNameEnv` go_dco dco
+     go_co (UnivCo p _ ty ty')    = go_prov go_co 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 (SelCo _ co)           = go_co co
@@ -153,15 +154,30 @@ synonymTyConsOfType ty
      go_co (SubCo co)             = go_co co
      go_co (AxiomRuleCo _ cs)     = go_co_s cs
 
-     go_prov (PhantomProv co)     = go_co co
-     go_prov (ProofIrrelProv co)  = go_co co
-     go_prov (PluginProv _)       = emptyNameEnv
-     go_prov (CorePrepProv _)     = emptyNameEnv
+     go_dco ReflDCo                = emptyNameEnv
+     go_dco (GReflRightDCo co)     = go_co co
+     go_dco (GReflLeftDCo  co)     = go_co co
+     go_dco (TyConAppDCo cs)       = go_dco_s cs
+     go_dco (AppDCo co co')        = go_dco co `plusNameEnv` go_dco co'
+     go_dco (ForAllDCo _ dco dco') = go_dco dco `plusNameEnv` go_dco dco'
+     go_dco (CoVarDCo _)           = emptyNameEnv
+     go_dco AxiomInstDCo{}         = emptyNameEnv
+     go_dco StepsDCo{}             = emptyNameEnv
+     go_dco (TransDCo co1 co2)     = go_dco co1 `plusNameEnv` go_dco co2
+     go_dco (DehydrateCo co)       = go_co co
+     go_dco (UnivDCo prov rhs)     = go_prov go_dco prov `plusNameEnv` go rhs
+     go_dco (SubDCo dco)           = go_dco dco
+
+     go_prov syns (PhantomProv co)     = syns co
+     go_prov syns (ProofIrrelProv co)  = syns co
+     go_prov _    (PluginProv _)       = emptyNameEnv
+     go_prov _    (CorePrepProv _)     = emptyNameEnv
 
      go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
               | otherwise             = emptyNameEnv
      go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
      go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
+     go_dco_s dcos = foldr (plusNameEnv . go_dco) emptyNameEnv dcos
 
 -- | A monad for type synonym cycle checking, which keeps
 -- track of the TyCons which are known to be acyclic, or
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 28668b7979..033327912d 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -293,8 +293,8 @@ data RewriteEnv
        -- ^ At what role are we rewriting?
        --
        -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite
-
-       , re_rewriters :: !(TcRef RewriterSet)  -- ^ See Note [Wanteds rewrite Wanteds]
+       , re_rewriters :: !(TcRef RewriterSet)
+       -- ^ See Note [Wanteds rewrite Wanteds]
        }
 -- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined
 -- here so that it can also be passed to rewriting plugins.
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index 4216613c4a..dbbe74faff 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -40,6 +40,7 @@ module GHC.Tc.Types.Evidence (
   -- * TcCoercion
   TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,
   TcMCoercion, TcMCoercionN, TcMCoercionR,
+  TcDCoercion,
   Role(..), LeftOrRight(..), pickLR,
   maybeSymCo,
   unwrapIP, wrapIP,
@@ -109,6 +110,7 @@ type TcCoercionP  = CoercionP    -- a phantom coercion
 type TcMCoercion  = MCoercion
 type TcMCoercionN = MCoercionN  -- nominal
 type TcMCoercionR = MCoercionR  -- representational
+type TcDCoercion  = DCoercion
 
 -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion
 maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 7db80cfccb..0e3e75ec38 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -79,7 +79,7 @@ module GHC.Tc.Utils.TcMType (
   zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,
   zonkTyCoVarsAndFVList,
 
-  zonkTcType, zonkTcTypes, zonkCo,
+  zonkTcType, zonkTcTypes, zonkCo, zonkCtEvidence,
   zonkTyCoVarKind,
   zonkEvVar, zonkWC, zonkImplication, zonkSimples,
   zonkId, zonkCoVar,
@@ -404,7 +404,7 @@ unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
 -- 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 :: CoVar -> Coercion -> TcM Coercion
+checkCoercionHole :: HasDebugCallStack => CoVar -> Coercion -> TcM Coercion
 checkCoercionHole cv co
   | debugIsOn
   = do { cv_ty <- zonkTcType (varType cv)
@@ -412,8 +412,10 @@ checkCoercionHole cv co
        ; return $
          assertPpr (ok cv_ty)
                    (text "Bad coercion hole" <+>
-                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
-                                             , ppr cv_ty ])
+                    ppr cv <> colon <+> vcat [ text "t1:" <+> ppr t1
+                                             , text "t2:" <+> ppr t2
+                                             , text "role:" <+> ppr role
+                                             , text "cv_ty:" <+> ppr cv_ty ])
          co }
   | otherwise
   = return co
@@ -1542,26 +1544,43 @@ collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors
                      -> VarSet -- bound variables
                      -> CandidatesQTvs -> Coercion
                      -> TcM CandidatesQTvs
-collect_cand_qtvs_co orig_ty cur_lvl bound = go_co
+collect_cand_qtvs_co orig_ty cur_lvl bound dv = fst $ collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv
+
+collect_cand_qtvs_dco :: TcType -- original type at top of recursion; for errors
+                      -> TcLevel
+                      -> VarSet -- bound variables
+                      -> CandidatesQTvs -> DCoercion
+                      -> TcM CandidatesQTvs
+collect_cand_qtvs_dco orig_ty cur_lvl bound dv = snd $ collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv
+
+collect_cand_qtvs_co_dco :: TcType -- original type at top of recursion; for errors
+                         -> TcLevel
+                         -> VarSet -- bound variables
+                         -> CandidatesQTvs
+                         -> (Coercion -> TcM CandidatesQTvs, DCoercion -> TcM CandidatesQTvs)
+collect_cand_qtvs_co_dco orig_ty cur_lvl bound dv = (go_co dv, go_dco dv)
   where
-    go_co dv (Refl ty)               = collect_cand_qtvs orig_ty True cur_lvl bound dv ty
-    go_co dv (GRefl _ ty mco)        = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty
-                                          ; go_mco dv1 mco }
-    go_co dv (TyConAppCo _ _ cos)    = foldlM go_co dv cos
-    go_co dv (AppCo co1 co2)         = foldlM go_co dv [co1, co2]
+    go_co :: CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
+    go_co dv (Refl ty)             = collect_cand_qtvs orig_ty True cur_lvl bound dv ty
+    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty
+                                        go_mco dv1 mco
+    go_co dv (TyConAppCo _ _ cos)  = foldlM go_co dv cos
+    go_co dv (AppCo co1 co2)       = foldlM go_co dv [co1, co2]
     go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2]
-    go_co dv (AxiomInstCo _ _ cos)   = foldlM go_co dv cos
-    go_co dv (AxiomRuleCo _ cos)     = foldlM go_co dv cos
-    go_co dv (UnivCo prov _ t1 t2)   = do { dv1 <- go_prov dv prov
-                                          ; dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1
-                                          ; collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2 }
-    go_co dv (SymCo co)              = go_co dv co
-    go_co dv (TransCo co1 co2)       = foldlM go_co dv [co1, co2]
-    go_co dv (SelCo _ co)            = go_co dv co
-    go_co dv (LRCo _ co)             = go_co dv co
-    go_co dv (InstCo co1 co2)        = foldlM go_co dv [co1, co2]
-    go_co dv (KindCo co)             = go_co dv co
-    go_co dv (SubCo co)              = go_co dv co
+    go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos
+    go_co dv (AxiomRuleCo _ cos)   = foldlM go_co dv cos
+    go_co dv (HydrateDCo _ t1 dco _) = do dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv t1
+                                          go_dco dv1 dco
+    go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov go_co dv prov
+                                        dv2 <- collect_cand_qtvs orig_ty True cur_lvl bound dv1 t1
+                                        collect_cand_qtvs orig_ty True cur_lvl bound dv2 t2
+    go_co dv (SymCo co)            = go_co dv co
+    go_co dv (TransCo co1 co2)     = foldlM go_co dv [co1, co2]
+    go_co dv (SelCo _ co)          = go_co dv co
+    go_co dv (LRCo _ co)           = go_co dv co
+    go_co dv (InstCo co1 co2)      = foldlM go_co dv [co1, co2]
+    go_co dv (KindCo co)           = go_co dv co
+    go_co dv (SubCo co)            = go_co dv co
 
     go_co dv (HoleCo hole)
       = do m_co <- unpackCoercionHole_maybe hole
@@ -1575,13 +1594,33 @@ collect_cand_qtvs_co orig_ty cur_lvl bound = go_co
       = do { dv1 <- go_co dv kind_co
            ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co }
 
+    go_dco :: CandidatesQTvs -> DCoercion -> TcM CandidatesQTvs
+    go_dco dv ReflDCo                = return dv
+    go_dco dv (GReflRightDCo co)     = go_co dv co
+    go_dco dv (GReflLeftDCo  co)     = go_co dv co
+    go_dco dv (TyConAppDCo cos)      = foldlM go_dco dv cos
+    go_dco dv (AppDCo co1 co2)       = foldlM go_dco dv [co1, co2]
+    go_dco dv AxiomInstDCo{}         = return dv
+    go_dco dv StepsDCo{}             = return dv
+    go_dco dv (TransDCo co1 co2)     = foldlM go_dco dv [co1, co2]
+    go_dco dv (CoVarDCo cv)          = go_cv dv cv
+
+    go_dco dv (ForAllDCo tcv kind_dco co)
+      = do { dv1 <- go_dco dv kind_dco
+           ; collect_cand_qtvs_dco orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co }
+
+    go_dco dv (DehydrateCo co)       = go_co dv co
+    go_dco dv (UnivDCo prov rhs)     = do dv1 <- go_prov go_dco dv prov
+                                          collect_cand_qtvs orig_ty True cur_lvl bound dv1 rhs
+    go_dco dv (SubDCo dco)           = go_dco dv dco
+
     go_mco dv MRefl    = return dv
     go_mco dv (MCo co) = go_co dv co
 
-    go_prov dv (PhantomProv co)    = go_co dv co
-    go_prov dv (ProofIrrelProv co) = go_co dv co
-    go_prov dv (PluginProv _)      = return dv
-    go_prov dv (CorePrepProv _)    = return dv
+    go_prov collect dv (PhantomProv co)    = collect dv co
+    go_prov collect dv (ProofIrrelProv co) = collect dv co
+    go_prov _       dv (PluginProv _)      = return dv
+    go_prov _       dv (CorePrepProv _)    = return dv
 
     go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
     go_cv dv@(DV { dv_cvs = cvs }) cv
@@ -2831,7 +2870,7 @@ zonkRewriterSet (RewriterSet set)
 
     check_ty :: Type -> UnfilledCoercionHoleMonoid
     check_co :: Coercion -> UnfilledCoercionHoleMonoid
-    (check_ty, _, check_co, _) = foldTyCo folder ()
+    (check_ty, _, check_co, _, _, _) = foldTyCo folder ()
 
     folder :: TyCoFolder () UnfilledCoercionHoleMonoid
     folder = TyCoFolder { tcf_view  = noView
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index ae25678600..223caa961c 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -1088,7 +1088,7 @@ exactTyCoVarsOfTypes tys = runTyCoVars (exact_tys tys)
 
 exact_ty  :: Type       -> Endo TyCoVarSet
 exact_tys :: [Type]     -> Endo TyCoVarSet
-(exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet
+(exact_ty, exact_tys, _, _, _, _) = foldTyCo exactTcvFolder emptyVarSet
 
 exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)
 exactTcvFolder = deepTcvFolder { tcf_view = coreView }
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 428eba5d69..c030993b6c 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -2685,7 +2685,7 @@ mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool)
 -- No expansion of type synonyms
 mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)
   where
-    !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet
+    !(check_ty, _, check_co, _, _check_dco, _) = foldTyCo occ_folder emptyVarSet
     occ_folder = TyCoFolder { tcf_view  = noView  -- Don't expand synonyms
                             , tcf_tyvar = do_tcv, tcf_covar = do_tcv
                             , tcf_hole  = do_hole
@@ -2786,7 +2786,7 @@ pprPur (PuFail prob) = text "PuFail:" <> ppr prob
 pprPur (PuOK {})     = text "PuOK"
 
 okCheckRefl :: TcType -> TcM (PuResult a Reduction)
-okCheckRefl ty = return (PuOK emptyBag (mkReflRedn Nominal ty))
+okCheckRefl ty = return (PuOK emptyBag (mkReflRedn ty))
 
 failCheckWith :: CheckTyEqResult -> TcM (PuResult a b)
 failCheckWith p = return (PuFail p)
@@ -2898,9 +2898,12 @@ checkTyEqRhs flags ty
        -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F)
        | otherwise
        -> do { w_res <- checkTyEqRhs flags w
+          --   ; a_rep <- fmap reductionDCoercion <$> checkTyEqRhs flags (getRuntimeRep a)
              ; a_res <- checkTyEqRhs flags a
+          --   ; r_rep <- fmap reductionDCoercion <$> checkTyEqRhs flags (getRuntimeRep r)
              ; r_res <- checkTyEqRhs flags r
-             ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) }
+             ; return (mkFunRedn af <$> w_res <*> pure ReflDCo <*> pure ReflDCo <*> a_res <*> r_res) }
+               -- SLD TODO not sure about this
 
       AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun
                           ; arg_res <- checkTyEqRhs flags arg
@@ -2908,10 +2911,10 @@ checkTyEqRhs flags ty
 
       CastTy ty co  -> do { ty_res <- checkTyEqRhs flags ty
                           ; co_res <- checkCo flags co
-                          ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }
+                          ; return (mkCastRedn1 <$> co_res <*> ty_res) }
 
       CoercionTy co -> do { co_res <- checkCo flags co
-                          ; return (mkReflCoRedn Nominal <$> co_res) }
+                          ; return (mkReflCoRedn <$> co_res) }
 
       ForAllTy {}
          | tef_foralls flags -> okCheckRefl ty
@@ -3095,7 +3098,7 @@ checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok })
 recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction)
 recurseIntoTyConApp flags tc tys
   = do { tys_res <- mapCheck (checkTyEqRhs flags) tys
-       ; return (mkTyConAppRedn Nominal tc <$> tys_res) }
+       ; return (mkTyConAppRedn tc <$> tys_res) }
 
 -------------------
 checkFamApp :: TyEqFlags a
@@ -3123,12 +3126,12 @@ checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob
       TEFA_Recurse
         -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys
               ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags)
-              ; return (mkTyConAppRedn Nominal tc <$> tys_res) }
+              ; return (mkTyConAppRedn tc <$> tys_res) }
 
       TEFA_Break breaker    -- Recurse; and break if there is a problem
         -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys
               ; case tys_res of
-                  PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns))
+                  PuOK cts redns -> return (PuOK cts (mkTyConAppRedn tc redns))
                   PuFail {}      -> breaker fam_app }
   where
     arg_flags = famAppArgFlags flags
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index d50e3a52ec..f4122241e6 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1048,9 +1048,9 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
   = HsLazy  -- For !Int#, say, use HsLazy
             -- See Note [Data con wrappers and unlifted types]
 
-  | let mb_co   = topNormaliseType_maybe fam_envs (scaledThing arg_ty)
+  | let mb_redn= topNormaliseType_maybe fam_envs (scaledThing arg_ty)
                      -- Unwrap type families and newtypes
-        arg_ty' = case mb_co of
+        arg_ty' = case mb_redn of
                     { Just redn -> scaledSet arg_ty (reductionReducedType redn)
                     ; Nothing   -> arg_ty }
   , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')
@@ -1058,9 +1058,10 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
   = if bang_opt_unbox_disable bang_opts
     then HsStrict True -- Not unpacking because of -O0
                        -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
-    else case mb_co of
+    else case mb_redn of
            Nothing   -> HsUnpack Nothing
-           Just redn -> HsUnpack (Just $ reductionCoercion redn)
+           Just redn -> HsUnpack $ Just $
+                        mkHydrateReductionDCoercion Representational (scaledThing arg_ty) redn
 
   | otherwise -- Record the strict-but-no-unpack decision
   = HsStrict False
diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst
index c75d5e6097..f492f87af8 100644
--- a/docs/users_guide/using-optimisation.rst
+++ b/docs/users_guide/using-optimisation.rst
@@ -813,6 +813,21 @@ as such you shouldn't need to set any of them explicitly. A flag
 
     Turn off the coercion optimiser.
 
+.. ghc-flag:: -fkeep-dcoercions
+    :shortdesc: Keep directed coercions in the coercion optimiser
+    :type: dynamic
+    :category:
+
+    :default: Don't keep directed coercions in the coercion optimiser.
+
+    Keep directed coercions in the coercion optimiser, instead of turning
+    them into coercions. Only applies when coercion optimisation is enabled.
+    Turning this flag on will ensure that coercions borne from type family reduction
+    remain small, but it means the coercion optimiser is less able to optimise them.
+    If your program crucially relies on coercion optimisation
+    (i.e. enabling :ghc-flag:`-fno-opt-coercion` causes a significant regression in compile-time),
+    then you might want to NOT enable this flag.
+
 .. ghc-flag:: -fno-pre-inlining
     :shortdesc: Turn off pre-inlining
     :type: dynamic
diff --git a/testsuite/tests/dcoercion/DCo_Array.hs b/testsuite/tests/dcoercion/DCo_Array.hs
new file mode 100644
index 0000000000..cf3e389a09
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Array.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE
+    MagicHash
+  , UnboxedTuples
+  , UnliftedFFITypes
+ #-}
+
+module DCo_Array where
+
+import DCo_Array_aux
+  ( memcpy_thaw )
+
+import GHC.Exts
+  ( Ptr, Int(I#), RealWorld
+  , MutableByteArray#, ByteArray#
+  , newByteArray#
+  )
+import GHC.IO ( IO(..) )
+import GHC.ST ( ST(..) )
+
+data UArray e = UArray !Int ByteArray#
+data STUArray s e = STUArray !Int (MutableByteArray# s)
+
+thawSTUArray :: UArray e -> ST RealWorld (STUArray RealWorld e)
+thawSTUArray (UArray n@(I# n#) arr#) = ST $ \s1# ->
+  case newByteArray# n# s1# of
+    (# s2#, marr# #) ->
+      case memcpy_thaw marr# arr# (fromIntegral n) of
+        IO m ->
+          case m s2# of
+            (# s3#, _ #) ->
+              (# s3#, STUArray n marr# #)
diff --git a/testsuite/tests/dcoercion/DCo_Array_aux.hs b/testsuite/tests/dcoercion/DCo_Array_aux.hs
new file mode 100644
index 0000000000..dbaf804349
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Array_aux.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE
+    DerivingStrategies
+  , MagicHash
+  , UnliftedFFITypes
+ #-}
+
+module DCo_Array_aux
+  ( memcpy_thaw ) where
+
+import Data.Word
+  ( Word32 )
+import GHC.Exts
+  ( MutableByteArray#, ByteArray#
+  , Ptr
+  )
+
+newtype CSize = CSize Word32
+  deriving newtype Num
+
+foreign import ccall unsafe "memcpy"
+    memcpy_thaw :: MutableByteArray# s -> ByteArray# -> CSize -> IO (Ptr a)
diff --git a/testsuite/tests/dcoercion/DCo_Coercion.hs b/testsuite/tests/dcoercion/DCo_Coercion.hs
new file mode 100644
index 0000000000..7a9d697c1a
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Coercion.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE PolyKinds           #-}
+
+module DCo_Coercion where
+
+import Data.Type.Equality
+  ( (:~:)(..), (:~~:)(..) )
+import Data.Coerce
+  ( Coercible, coerce )
+
+data Coercion a b where
+  Coercion :: Coercible a b => Coercion a b
+
+class TestCoercion f where
+  testCoercion :: f a -> f b -> Maybe (Coercion a b)
+
+instance TestCoercion ((:~:) a) where
+  testCoercion Refl Refl = Just Coercion
+
+instance TestCoercion ((:~~:) a) where
+  testCoercion HRefl HRefl = Just Coercion
diff --git a/testsuite/tests/dcoercion/DCo_Hetero.hs b/testsuite/tests/dcoercion/DCo_Hetero.hs
new file mode 100644
index 0000000000..fb1e479a96
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Hetero.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE MultiParamTypeClasses    #-}
+{-# LANGUAGE NoImplicitPrelude        #-}
+{-# LANGUAGE PolyKinds                #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE StandaloneDeriving       #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE Trustworthy              #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE UndecidableInstances     #-}
+
+module DCo_Hetero where
+
+import GHC.Enum
+import GHC.Base
+
+type (:~~:) :: k1 -> k2 -> Type
+data a :~~: b where
+   HRefl :: a :~~: a
+
+instance a ~~ b => Enum (a :~~: b) where
+  toEnum = error "toEnum"
diff --git a/testsuite/tests/dcoercion/DCo_Hetero.stderr b/testsuite/tests/dcoercion/DCo_Hetero.stderr
index 887e81669b..2332767804 100644
--- a/testsuite/tests/dcoercion/DCo_Hetero.stderr
+++ b/testsuite/tests/dcoercion/DCo_Hetero.stderr
@@ -1,5 +1,9 @@
 
+<<<<<<< HEAD
 DCo_Hetero.hs:24:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)]
+=======
+DCo_Hetero.hs:24:10: warning: [-Wmissing-methods (in -Wdefault)]
+>>>>>>> efc617419c (Directed coercions)
     • No explicit implementation for
         ‘fromEnum’
     • In the instance declaration for ‘Enum (a :~~: b)’
diff --git a/testsuite/tests/dcoercion/DCo_HsBinds.hs b/testsuite/tests/dcoercion/DCo_HsBinds.hs
new file mode 100644
index 0000000000..668231e067
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_HsBinds.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
+
+module DCo_HsBinds where
+
+import Prelude
+
+data GhcPass p where
+  GhcPs :: GhcPass Int
+  GhcRn :: GhcPass Float
+  GhcTc :: GhcPass Bool
+
+type HsPatSynDetails pass = [RecordPatSynField pass]
+data RecordPatSynField pass = RecordPatSynField ()
+
+-----------------------------------------
+
+class Outputable a where
+  methD :: a -> String
+
+instance Outputable (HsPatSynDetails (GhcPass r)) where
+  methD details = ppr_v =<< details
+    where
+      ppr_v v = case undefined :: GhcPass r of
+        GhcPs -> methD v
+        GhcRn -> methD v
+        GhcTc -> methD v
+
+instance Outputable (RecordPatSynField a) where
+  methD (RecordPatSynField v) = methD v
+
+instance Outputable () where
+  methD _ = "()"
diff --git a/testsuite/tests/dcoercion/DCo_HsType.hs b/testsuite/tests/dcoercion/DCo_HsType.hs
new file mode 100644
index 0000000000..067b5a8091
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_HsType.hs
@@ -0,0 +1,47 @@
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module DCo_HsType ( hsWcScopedTvs ) where
+
+import Prelude (undefined)
+
+data GhcPass (c :: Pass)
+data Pass = Renamed | Typechecked
+type GhcRn   = GhcPass 'Renamed
+
+data HsTyVarBndr pass
+type LHsTyVarBndr pass = XRec pass (HsTyVarBndr pass)
+
+type LHsSigType   pass = XRec pass (HsSigType pass)
+type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass)
+
+type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs
+data HsSigType pass
+  = HsSig { sig_bndrs :: HsOuterSigTyVarBndrs pass }
+
+data HsWildCardBndrs pass thing
+  = HsWC { hswc_body :: thing }
+
+data HsOuterTyVarBndrs pass
+
+type family NoGhcTc p
+type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)
+
+type family NoGhcTcPass (p :: Pass) :: Pass where
+  NoGhcTcPass 'Typechecked = 'Renamed
+  NoGhcTcPass other        = other
+
+type family   XRec p           a
+type instance XRec (GhcPass p) a = a
+
+hsOuterExplicitBndrs :: HsOuterTyVarBndrs (GhcPass p)
+                     -> LHsTyVarBndr (NoGhcTc (GhcPass p))
+hsOuterExplicitBndrs = undefined
+
+hsWcScopedTvs :: LHsSigWcType GhcRn -> LHsTyVarBndr GhcRn
+hsWcScopedTvs sig_wc_ty
+  | HsWC { hswc_body = sig_ty } <- sig_wc_ty
+  , HsSig { sig_bndrs = outer_bndrs } <- sig_ty
+  = hsOuterExplicitBndrs outer_bndrs
diff --git a/testsuite/tests/dcoercion/DCo_InScope.hs b/testsuite/tests/dcoercion/DCo_InScope.hs
new file mode 100644
index 0000000000..083617f452
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_InScope.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE
+    ScopedTypeVariables
+  , DataKinds
+  , GADTs
+  , RankNTypes
+  , TypeOperators
+  , PolyKinds -- Comment out PolyKinds and the bug goes away.
+  #-}
+{-# OPTIONS_GHC -O #-}
+
+module DCo_InScope where
+
+import Data.Kind
+
+data AccValidation err a = AccFailure err | AccSuccess a
+
+data KeyValueError = MissingValue
+
+type WithKeyValueError = AccValidation [KeyValueError]
+
+missing :: forall f rs. RecApplicative rs -> Rec (WithKeyValueError :. f) rs
+missing (RecApplicative rpure) = rpure missingField
+  where
+    missingField :: forall x. (WithKeyValueError :. f) x
+    missingField = Compose $ AccFailure [MissingValue]
+
+data Rec :: (u -> Type) -> [u] -> Type where
+  RNil :: Rec f '[]
+  (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)
+
+newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k)
+  = Compose { getCompose :: f (g x) }
+
+type (:.) f g = Compose f g
+
+newtype RecApplicative rs =
+  RecApplicative ( forall f. (forall x. f x) -> Rec f rs )
diff --git a/testsuite/tests/dcoercion/DCo_LiftTyped.hs b/testsuite/tests/dcoercion/DCo_LiftTyped.hs
new file mode 100644
index 0000000000..8b253743b4
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_LiftTyped.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE
+    DefaultSignatures
+  , MultiParamTypeClasses
+  , GADTs
+  , PolyKinds
+  , ScopedTypeVariables
+  , StandaloneKindSignatures
+#-}
+
+module ThSyntax where
+
+import Data.Kind
+import GHC.Exts
+
+type Code :: forall r. TYPE r -> Type
+data Code a = Code
+
+unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) . Code a -> ()
+unTypeCode _ = ()
+
+type Lift :: forall r -> TYPE r -> Constraint
+class Lift r t where
+  lift :: t -> ()
+  default lift :: (r ~ ('BoxedRep 'Lifted)) => t -> ()
+  lift = unTypeCode . liftTyped
+  liftTyped :: t -> Code t
diff --git a/testsuite/tests/dcoercion/DCo_Phantom.hs b/testsuite/tests/dcoercion/DCo_Phantom.hs
new file mode 100644
index 0000000000..eceb3fc0ee
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Phantom.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies,
+             UndecidableInstances, ConstraintKinds #-}
+module DCo_Phantom where
+
+import GHC.TypeLits as L
+import Data.Type.Bool
+
+
+-- We define a very simplistic O notation, with sufficient expressiveness
+-- to capture the complexity of a few simple sorting algorithms
+data AsympPoly = NLogN Nat Nat
+
+-- Synonyms for common terms
+type N     = NLogN 1 0
+type LogN  = NLogN 0 1
+type One   = NLogN 0 0
+
+-- Just to be able to write it nicely
+type O (a :: AsympPoly) = a
+
+type family (^.) (n :: AsympPoly) (m :: Nat) :: AsympPoly where
+  (NLogN a b) ^. n = (NLogN (a L.* n) (b L.* n))
+
+infixl 7 ^.
+
+newtype Sorted (cpu :: AsympPoly) -- The minimum operational complexity
+                                       -- this algorithm satisfies.
+               (mem :: AsympPoly) -- The minimum space complexity this
+                                       -- algorithm satisfies.
+               (stable :: Bool)        -- Whether the sort is stable or not.
+               a                       -- What was being sorted.
+               = Sorted {sortedBy :: [a]}
+
+mySortA :: Sorted (O(N^.2)) (O(N)) True Integer
+mySortA = _a [3,1,2]
diff --git a/testsuite/tests/dcoercion/DCo_PostProcess.hs b/testsuite/tests/dcoercion/DCo_PostProcess.hs
new file mode 100644
index 0000000000..ffd5ae8eeb
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_PostProcess.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+
+module DCo_PostProcess where
+
+data RdrName
+data SrcSpanAnnN
+
+type family Anno a
+type instance Anno RdrName = SrcSpanAnnN
+
+data Pass = Parsed
+data GhcPass (c :: Pass) where
+  GhcPs :: GhcPass 'Parsed
+type GhcPs = GhcPass 'Parsed
+
+type family IdP p
+type instance IdP (GhcPass p) = IdGhcP p
+type family IdGhcP pass where
+  IdGhcP 'Parsed = RdrName
+
+mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)
+         => IdP (GhcPass p) -> GhcPass p
+mkHsOpTy = mkHsOpTy
+
+mkLHsOpTy :: RdrName -> GhcPs
+mkLHsOpTy = mkHsOpTy
diff --git a/testsuite/tests/dcoercion/DCo_Specialise.hs b/testsuite/tests/dcoercion/DCo_Specialise.hs
new file mode 100644
index 0000000000..fde5bfb54f
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Specialise.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE Haskell2010 #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module DCo_Specialise ( rnStmts1 ) where
+
+data RealWorld
+newtype M a = M (RealWorld -> a)
+fmapM :: (a -> b) -> M a -> M b
+fmapM f (M k) = M (f . k)
+
+data HsExpr
+data SrcSpanAnnA
+
+type family   Anno a
+type instance Anno HsExpr = SrcSpanAnnA
+
+type AnnoBody body0_ = ( Anno body0_ ~ SrcSpanAnnA )
+
+rnStmts1 :: forall body1_ thing1_. AnnoBody body1_ => M (body1_, thing1_)
+rnStmts1 = rnStmts2 @body1_ @thing1_
+
+rnStmts2 :: forall body2_ thing2_. AnnoBody body2_ => M (body2_, thing2_)
+rnStmts2 = rnStmts3 @(body2_, thing2_)
+
+rnStmts3 :: M thing3_
+rnStmts3 = fmapM snd $ rnStmts1 @HsExpr
diff --git a/testsuite/tests/dcoercion/DCo_T15703_aux.hs b/testsuite/tests/dcoercion/DCo_T15703_aux.hs
new file mode 100644
index 0000000000..306a39e7a0
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_T15703_aux.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module DCo_T15703_aux where
+
+import Data.Kind
+import Data.Type.Equality
+import GHC.Generics
+
+data family Sing :: forall k. k -> Type
+data instance Sing :: forall i k c (p :: k). K1 i c p -> Type where
+  SK1 :: Sing x -> Sing ('K1 x)
+data instance Sing :: forall k i (c :: Meta) (f :: k -> Type) (p :: k).
+                      M1 i c f p -> Type where
+  SM1 :: Sing x -> Sing ('M1 x)
+
+data instance Sing :: forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
+                      (f :*: g) p -> Type where
+  (:%*:) :: Sing x -> Sing y -> Sing (x ':*: y)
+
+data instance Sing :: forall p. Par1 p -> Type where
+  SPar1 :: Sing x -> Sing ('Par1 x)
+
+class PGeneric1 (f :: k -> Type) where
+  type From1 (z :: f a)      :: Rep1 f a
+  type To1   (z :: Rep1 f a) :: f a
+
+class VGeneric1 (f :: k -> Type) where
+  sFot1 :: forall (a :: k) (r :: Rep1 f a). Sing r -> From1 (To1 r :: f a) :~: r
+
+instance PGeneric1 ((,) a) where
+  type From1 '(x, y) = 'M1 ('M1 ('M1 ('K1 x) ':*: 'M1 ('Par1 y)))
+  type To1   ('M1 ('M1 ('M1 ('K1 x) ':*: 'M1 ('Par1 y)))) = '(x, y)
+
+instance VGeneric1 ((,) a) where
+  sFot1 (SM1 (SM1 (SM1 SK1{} :%*: SM1 SPar1{}))) = Refl
diff --git a/testsuite/tests/dcoercion/DCo_TransOpt.hs b/testsuite/tests/dcoercion/DCo_TransOpt.hs
new file mode 100644
index 0000000000..e89ac6f113
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_TransOpt.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Main where
+
+-- base
+import Data.Foldable
+  ( for_ )
+
+-- ghc
+import GHC.Core.Coercion
+  ( DCoercion(ReflDCo, StepsDCo, TransDCo, TyConAppDCo)
+  , mkTransDCo
+  )
+
+-------------------------------------------------------------------------------
+
+main :: IO ()
+main =
+  for_ test_dcos \ ( nm, dco ) ->
+    case unreducedTopTransitivities dco of
+      Nothing -> do
+        putStrLn $ "OK:   " ++ nm
+        putStrLn $ "      " ++ show_dco dco
+      Just ( i, l, r ) -> do
+        putStrLn $ "FAIL: " ++ nm
+        putStrLn $ "      " ++ show_dco dco
+        putStrLn $ "       unreduced pair at index " ++ show i
+        putStrLn $ "       LHS:" ++ show_dco l
+        putStrLn $ "       RHS:" ++ show_dco r
+
+unreducedTopTransitivities
+  :: DCoercion -> Maybe ( Int, DCoercion, DCoercion )
+unreducedTopTransitivities
+  = check_reductions . top_trans
+
+top_trans :: DCoercion -> [ DCoercion ]
+top_trans = \case
+  ldco `TransDCo` rdco -> top_trans ldco ++ top_trans rdco
+  dco                  -> [dco]
+
+check_reductions :: [ DCoercion ] -> Maybe ( Int, DCoercion, DCoercion )
+check_reductions = go 0
+  where
+    go i ( dco1 : dco2 : dcos )
+      | should_cancel dco1 dco2
+      = Just ( i, dco1, dco2 )
+      | otherwise
+      = go (i+1) ( dco2 : dcos )
+    go _ _ = Nothing
+
+should_cancel :: DCoercion -> DCoercion -> Bool
+should_cancel ReflDCo _ = True
+should_cancel _ ReflDCo = True
+should_cancel (StepsDCo {}) (StepsDCo {}) = True
+should_cancel _ _ = False
+
+--------------------------------------------------------------------------------
+-- Handwritten directed coercions used for testing...
+
+-- Assume the LHS cannot be simplified further.
+test_lhs_dco_1 = ReflDCo
+test_lhs_dco_2 = StepsDCo 3
+test_lhs_dco_3 = TyConAppDCo [] `TransDCo` StepsDCo 3
+test_lhs_dco_4 = ( TyConAppDCo [] `TransDCo` TyConAppDCo [] ) `TransDCo` StepsDCo 3
+test_lhs_dco_5 = TyConAppDCo [] `TransDCo` ( TyConAppDCo [] `TransDCo` StepsDCo 3 )
+
+-- Don't make any such assumptions about the RHS.
+test_rhs_dco_1 = ReflDCo
+test_rhs_dco_2 = StepsDCo 3
+test_rhs_dco_3 = StepsDCo 3 `mkTransDCo` StepsDCo 10
+test_rhs_dco_4 = ReflDCo `mkTransDCo` TyConAppDCo []
+test_rhs_dco_5 = StepsDCo 4 `mkTransDCo` TyConAppDCo []
+test_rhs_dco_6 = ( ReflDCo `mkTransDCo` TyConAppDCo [] ) `mkTransDCo` TyConAppDCo []
+test_rhs_dco_7 = ( StepsDCo 4 `mkTransDCo` TyConAppDCo [] ) `mkTransDCo` TyConAppDCo []
+test_rhs_dco_8 = ReflDCo
+    `mkTransDCo` ( ReflDCo `mkTransDCo` StepsDCo 100 `mkTransDCo` ReflDCo )
+    `mkTransDCo` ReflDCo
+
+test_lhs_dcos :: [ ( String, DCoercion ) ]
+test_lhs_dcos = [ ( "lhs 1", test_lhs_dco_1 )
+                , ( "lhs 2", test_lhs_dco_2 )
+                , ( "lhs 3", test_lhs_dco_3 )
+                , ( "lhs 4", test_lhs_dco_4 )
+                , ( "lhs 5", test_lhs_dco_5 ) ]
+
+test_rhs_dcos :: [ ( String, DCoercion ) ]
+test_rhs_dcos = [ ( "rhs 1", test_rhs_dco_1 )
+                , ( "rhs 2", test_rhs_dco_2 )
+                , ( "rhs 3", test_rhs_dco_3 )
+                , ( "rhs 4", test_rhs_dco_4 )
+                , ( "rhs 5", test_rhs_dco_5 )
+                , ( "rhs 6", test_rhs_dco_6 )
+                , ( "rhs 7", test_rhs_dco_7 )
+                , ( "rhs 8", test_rhs_dco_8 )]
+
+test_dcos :: [ ( String, DCoercion ) ]
+test_dcos = [ ( l_nm ++ ", " ++ r_nm, lhs `mkTransDCo` rhs )
+            | (l_nm, lhs) <- test_lhs_dcos
+            , (r_nm, rhs) <- test_rhs_dcos ]
+
+show_dco :: DCoercion -> String
+show_dco = \case
+  ReflDCo        -> "Refl"
+  StepsDCo n     -> show n
+  TyConAppDCo {} -> "TC"
+  l `TransDCo` r -> show_dco l ++ " ; " ++ show_dco r
+  _              -> "???"
diff --git a/testsuite/tests/dcoercion/DCo_TransOpt.stdout b/testsuite/tests/dcoercion/DCo_TransOpt.stdout
new file mode 100644
index 0000000000..d2a85459ba
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_TransOpt.stdout
@@ -0,0 +1,80 @@
+OK:   lhs 1, rhs 1
+      Refl
+OK:   lhs 1, rhs 2
+      3
+OK:   lhs 1, rhs 3
+      13
+OK:   lhs 1, rhs 4
+      TC
+OK:   lhs 1, rhs 5
+      4 ; TC
+OK:   lhs 1, rhs 6
+      TC ; TC
+OK:   lhs 1, rhs 7
+      4 ; TC ; TC
+OK:   lhs 1, rhs 8
+      100
+OK:   lhs 2, rhs 1
+      3
+OK:   lhs 2, rhs 2
+      6
+OK:   lhs 2, rhs 3
+      16
+OK:   lhs 2, rhs 4
+      3 ; TC
+OK:   lhs 2, rhs 5
+      7 ; TC
+OK:   lhs 2, rhs 6
+      3 ; TC ; TC
+OK:   lhs 2, rhs 7
+      7 ; TC ; TC
+OK:   lhs 2, rhs 8
+      103
+OK:   lhs 3, rhs 1
+      TC ; 3
+OK:   lhs 3, rhs 2
+      TC ; 6
+OK:   lhs 3, rhs 3
+      TC ; 16
+OK:   lhs 3, rhs 4
+      TC ; 3 ; TC
+OK:   lhs 3, rhs 5
+      TC ; 7 ; TC
+OK:   lhs 3, rhs 6
+      TC ; 3 ; TC ; TC
+OK:   lhs 3, rhs 7
+      TC ; 7 ; TC ; TC
+OK:   lhs 3, rhs 8
+      TC ; 103
+OK:   lhs 4, rhs 1
+      TC ; TC ; 3
+OK:   lhs 4, rhs 2
+      TC ; TC ; 6
+OK:   lhs 4, rhs 3
+      TC ; TC ; 16
+OK:   lhs 4, rhs 4
+      TC ; TC ; 3 ; TC
+OK:   lhs 4, rhs 5
+      TC ; TC ; 7 ; TC
+OK:   lhs 4, rhs 6
+      TC ; TC ; 3 ; TC ; TC
+OK:   lhs 4, rhs 7
+      TC ; TC ; 7 ; TC ; TC
+OK:   lhs 4, rhs 8
+      TC ; TC ; 103
+OK:   lhs 5, rhs 1
+      TC ; TC ; 3
+OK:   lhs 5, rhs 2
+      TC ; TC ; 6
+OK:   lhs 5, rhs 3
+      TC ; TC ; 16
+OK:   lhs 5, rhs 4
+      TC ; TC ; 3 ; TC
+OK:   lhs 5, rhs 5
+      TC ; TC ; 7 ; TC
+OK:   lhs 5, rhs 6
+      TC ; TC ; 3 ; TC ; TC
+OK:   lhs 5, rhs 7
+      TC ; TC ; 7 ; TC ; TC
+OK:   lhs 5, rhs 8
+      TC ; TC ; 103
diff --git a/testsuite/tests/dcoercion/DCo_TypeRep.hs b/testsuite/tests/dcoercion/DCo_TypeRep.hs
new file mode 100644
index 0000000000..161b449fde
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_TypeRep.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE GADTs, RankNTypes, PatternSynonyms, PolyKinds, ViewPatterns, TypeOperators #-}
+
+module DCo_TypeRep where
+
+import Type.Reflection (SomeTypeRep(SomeTypeRep), pattern Fun, typeRepKind )
+
+------------------------------------------------------------------------
+
+getSomeTypeRep :: SomeTypeRep
+getSomeTypeRep
+  | SomeTypeRep f <- getSomeTypeRep
+  = case typeRepKind f of
+      Fun _ _ -> error (show f)
+      _       -> error "not fun"
diff --git a/testsuite/tests/dcoercion/DCo_Typeable.hs b/testsuite/tests/dcoercion/DCo_Typeable.hs
new file mode 100644
index 0000000000..4470bafc17
--- /dev/null
+++ b/testsuite/tests/dcoercion/DCo_Typeable.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module DCo_Typeable where
+
+import GHC.Prim ( TYPE )
+import GHC.Base ( Type, RuntimeRep(BoxedRep), Levity(Lifted), undefined )
+
+splitApp :: TypeRep a -> AppOrCon a
+splitApp TrType = IsApp trTYPE trLiftedRep
+  where
+    trTYPE :: TypeRep TYPE
+    trTYPE = undefined
+    trLiftedRep :: TypeRep ('BoxedRep 'Lifted)
+    trLiftedRep = undefined
+
+type TypeRep :: k -> Type
+data TypeRep (a :: k) where
+  TrType :: TypeRep Type
+
+data AppOrCon (a :: k) where
+  IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
+        => TypeRep f %1 -> TypeRep x %1 -> AppOrCon (f x)
diff --git a/testsuite/tests/dcoercion/Makefile b/testsuite/tests/dcoercion/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/dcoercion/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/dcoercion/all.T b/testsuite/tests/dcoercion/all.T
new file mode 100644
index 0000000000..63cd5f1a11
--- /dev/null
+++ b/testsuite/tests/dcoercion/all.T
@@ -0,0 +1,19 @@
+
+## Correctness tests: these programs should compile and pass Core Lint.
+test('DCo_Array', [extra_files(['DCo_Array_aux.hs'])], multimod_compile, ['DCo_Array.hs', '-v0 -O'])
+test('DCo_Coercion', normal, compile, ['-O'])
+test('DCo_Hetero', normal, compile, [''])
+test('DCo_HsBinds', normal, compile, ['-O'])
+test('DCo_HsType', normal, compile, [''])
+test('DCo_InScope', normal, compile, [''])
+test('DCo_LiftTyped', normal, compile, [''])
+test('DCo_Phantom', normal, compile, ['-fdefer-type-errors'])
+test('DCo_PostProcess', normal, compile, [''])
+test('DCo_Specialise', normal, compile, [''])
+test('DCo_T15703_aux', normal, compile, ['-O'])
+test('DCo_Typeable', normal, compile, ['-O'])
+test('DCo_TypeRep', normal, compile, [''])
+
+## The following tests that we optimise away certain transitive coercions.
+## However, this optimisation was too slow, so we comment this out for now.
+#test('DCo_TransOpt', normal, compile_and_run, ['-package ghc'])
diff --git a/testsuite/tests/dependent/should_compile/T14729.stderr b/testsuite/tests/dependent/should_compile/T14729.stderr
index 0aa6ad7f10..1a9a78dac7 100644
--- a/testsuite/tests/dependent/should_compile/T14729.stderr
+++ b/testsuite/tests/dependent/should_compile/T14729.stderr
@@ -1,5 +1,7 @@
 TYPE SIGNATURES
-  x :: forall (x :: Bool). P (F Int) (x |> Sym (T14729.D:R:FInt[0]))
+  x ::
+    forall (x :: Bool).
+    P (F Int) (x |> Sym (Hydrate nominal (F Int) T14729.D:R:FInt))
   y :: forall {x :: Bool}. P Bool x
 TYPE CONSTRUCTORS
   type family F{1} :: * -> *
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 14cd4cce94..d0c60235a0 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -171,7 +171,7 @@ test ('T8095',
       [ only_ways(['normal']),
         collect_compiler_stats('bytes allocated',2) ],
       compile,
-      ['-v0 -O'])
+      ['-v0 -O -fkeep-dcoercions'])
 test ('T13386',
       [ only_ways(['normal']),
         collect_compiler_stats('bytes allocated',1) ],
@@ -208,7 +208,7 @@ test ('LargeRecord',
       , extra_files(['SuperRecord.hs'])
       ],
       multimod_compile,
-      ['LargeRecord', '-v0 -O'])
+      ['LargeRecord', '-v0 -O -fkeep-dcoercions'])
 
 test('T9961',
      [ only_ways(['normal']),
@@ -245,7 +245,7 @@ test('T12227',
      ],
      compile,
      # Use `-M1G` to prevent memory thrashing with ghc-8.0.1.
-     ['-O2 -ddump-hi -ddump-to-file +RTS -M1G'])
+     ['-O2 -fkeep-dcoercions -ddump-hi -ddump-to-file +RTS -M1G'])
 
 test('T12425',
      [ only_ways(['optasm']),
diff --git a/testsuite/tests/pmcheck/should_compile/T11195.hs b/testsuite/tests/pmcheck/should_compile/T11195.hs
index 7a7a4b05c5..b377eb2851 100644
--- a/testsuite/tests/pmcheck/should_compile/T11195.hs
+++ b/testsuite/tests/pmcheck/should_compile/T11195.hs
@@ -34,7 +34,7 @@ optForAllCoBndr = undefined
 opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
 opt_trans = undefined
 
-opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
+opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance Coercion -> Role
          -> Type -> Type -> Coercion
 opt_univ = undefined
 
diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr
index 92e8cace91..46119f59b9 100644
--- a/testsuite/tests/roles/should_compile/Roles13.stderr
+++ b/testsuite/tests/roles/should_compile/Roles13.stderr
@@ -1,20 +1,25 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 98, types: 38, coercions: 6, joins: 0/0}
+  = {terms: 98, types: 38, coercions: 8, joins: 0/0}
 
 -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
 convert1 :: Wrap Age -> Wrap Age
 [GblId, Arity=1, Unf=OtherCon []]
 convert1 = \ (ds :: Wrap Age) -> ds
 
--- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0}
+-- RHS size: {terms: 1, types: 0, coercions: 8, joins: 0/0}
 convert :: Wrap Age -> Int
 [GblId, Arity=1, Unf=OtherCon []]
 convert
   = convert1
     `cast` (<Wrap Age>_R
+<<<<<<< HEAD
             %<Many>_N ->_R Roles13.N:Wrap[0] (Roles13.N:Age[0])
+=======
+            %<'Many>_N ->_R Roles13.N:Wrap[0] <Age>_R
+                            ; Roles13.N:Age[0]
+>>>>>>> ea654ed05a (Directed coercions)
             :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int))
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
@@ -69,8 +74,13 @@ Roles13.$tcAge :: GHC.Types.TyCon
 [GblId, Unf=OtherCon []]
 Roles13.$tcAge
   = GHC.Types.TyCon
+<<<<<<< HEAD
       3456257068627873222#Word64
       14056710845110756026#Word64
+=======
+      3456257068627873222##64
+      14056710845110756026##64
+>>>>>>> ea654ed05a (Directed coercions)
       Roles13.$trModule
       $tcAge2
       0#
@@ -103,8 +113,13 @@ Roles13.$tc'MkAge :: GHC.Types.TyCon
 [GblId, Unf=OtherCon []]
 Roles13.$tc'MkAge
   = GHC.Types.TyCon
+<<<<<<< HEAD
       18264039750958872441#Word64
       1870189534242358050#Word64
+=======
+      18264039750958872441##64
+      1870189534242358050##64
+>>>>>>> ea654ed05a (Directed coercions)
       Roles13.$trModule
       $tc'MkAge2
       0#
@@ -125,8 +140,13 @@ Roles13.$tcWrap :: GHC.Types.TyCon
 [GblId, Unf=OtherCon []]
 Roles13.$tcWrap
   = GHC.Types.TyCon
+<<<<<<< HEAD
       13773534096961634492#Word64
       15591525585626702988#Word64
+=======
+      13773534096961634492##64
+      15591525585626702988##64
+>>>>>>> ea654ed05a (Directed coercions)
       Roles13.$trModule
       $tcWrap2
       0#
@@ -164,8 +184,13 @@ Roles13.$tc'MkWrap :: GHC.Types.TyCon
 [GblId, Unf=OtherCon []]
 Roles13.$tc'MkWrap
   = GHC.Types.TyCon
+<<<<<<< HEAD
       15580677875333883466#Word64
       808508687714473149#Word64
+=======
+      15580677875333883466##64
+      808508687714473149##64
+>>>>>>> ea654ed05a (Directed coercions)
       Roles13.$trModule
       $tc'MkWrap2
       1#
diff --git a/testsuite/tests/tcplugins/RewritePlugin.hs b/testsuite/tests/tcplugins/RewritePlugin.hs
index 10aa7574a4..e6e8241b39 100644
--- a/testsuite/tests/tcplugins/RewritePlugin.hs
+++ b/testsuite/tests/tcplugins/RewritePlugin.hs
@@ -14,7 +14,7 @@ import GHC.Builtin.Types
 import GHC.Core
   ( Expr(Coercion) )
 import GHC.Core.Coercion
-  ( Coercion, mkUnivCo )
+  ( DCoercion, mkUnivDCo )
 import GHC.Core.Predicate
   ( EqRel(NomEq), Pred(EqPred)
   , classifyPredType
@@ -82,8 +82,7 @@ rewriteAdd _ _ _ _ = pure TcPluginNoRewrite
 
 
 mkTyFamReduction :: TyCon -> [ Type ] -> Type -> Reduction
-mkTyFamReduction tyCon args res = Reduction co res
+mkTyFamReduction tyCon args res = Reduction (mkTyConApp tyCon args) dco res
   where
-    co :: Coercion
-    co = mkUnivCo ( PluginProv "RewritePlugin" ) Nominal
-           ( mkTyConApp tyCon args ) res
+    dco :: DCoercion
+    dco = mkUnivDCo (PluginProv "RewritePlugin") res