Move core flattening algorithm to Core.Unify

This sets the stage for a later change, where this
algorithm will be needed from GHC.Core.InstEnv.

This commit also splits GHC.Core.Map into
GHC.Core.Map.Type and GHC.Core.Map.Expr,
in order to avoid module import cycles
with GHC.Core.

17 files changed, 731 insertions, 693 deletions

diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
index d88745ad21..ffb4562c40 100644
--- a/compiler/GHC/Cmm/CommonBlockElim.hs
+++ b/compiler/GHC/Cmm/CommonBlockElim.hs
@@ -301,7 +301,7 @@ copyTicks env g
              foldr blockCons code (map CmmTick ticks)
 
 -- Group by [Label]
--- See Note [Compressed TrieMap] in GHC.Core.Map about the usage of GenMap.
+-- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap.
 groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
 groupByLabel =
   go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 76ffde9c4d..3769fb23be 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -24,7 +24,6 @@ import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
-import GHC.Core.FamInstEnv ( flattenTys )
 import GHC.Data.Pair
 import GHC.Data.List.SetOps ( getNth )
 import GHC.Core.Unify
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 0744d512f3..c5445fceae 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -35,10 +35,7 @@ module GHC.Core.FamInstEnv (
         -- Normalisation
         topNormaliseType, topNormaliseType_maybe,
         normaliseType, normaliseTcApp,
-        topReduceTyFamApp_maybe, reduceTyFamApp_maybe,
-
-        -- Flattening
-        flattenTys
+        topReduceTyFamApp_maybe, reduceTyFamApp_maybe
     ) where
 
 #include "HsVersions.h"
@@ -56,11 +53,8 @@ import GHC.Types.Var.Env
 import GHC.Types.Name
 import GHC.Types.Unique.DFM
 import GHC.Data.Maybe
-import GHC.Core.Map
-import GHC.Types.Unique
 import GHC.Types.Var
 import GHC.Types.SrcLoc
-import GHC.Data.FastString
 import Control.Monad
 import Data.List( mapAccumL )
 import Data.Array( Array, assocs )
@@ -434,7 +428,7 @@ Here is how we do it:
 apart(target, pattern) = not (unify(flatten(target), pattern))
 
 where flatten (implemented in flattenTys, below) converts all type-family
-applications into fresh variables. (See Note [Flattening].)
+applications into fresh variables. (See Note [Flattening] in GHC.Core.Unify.)
 
 Note [Compatibility]
 ~~~~~~~~~~~~~~~~~~~~
@@ -1181,7 +1175,7 @@ findBranch branches target_tys
                         , cab_incomps = incomps }) = branch
             in_scope = mkInScopeSet (unionVarSets $
                             map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
-            -- See Note [Flattening] below
+            -- See Note [Flattening] in GHC.Core.Unify
             flattened_target = flattenTys in_scope target_tys
         in case tcMatchTys tpl_lhs target_tys of
         Just subst -- matching worked. now, check for apartness.
@@ -1199,7 +1193,8 @@ findBranch branches target_tys
 -- ('CoAxBranch') of a closed type family can be used to reduce a certain target
 -- type family application.
 apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure
-                             -- they're flattened! See Note [Flattening].
+                             -- they're flattened! See Note [Flattening]
+                             -- in GHC.Core.Unify
                              -- (NB: This "flat" is a different
                              -- "flat" than is used in GHC.Tc.Solver.Flatten.)
                -> CoAxBranch -- ^ the candidate equation we wish to use
@@ -1565,292 +1560,3 @@ instance Monad NormM where
 instance Applicative NormM where
   pure x = NormM $ \ _ _ _ -> x
   (<*>)  = ap
-
-{-
-************************************************************************
-*                                                                      *
-              Flattening
-*                                                                      *
-************************************************************************
-
-Note [Flattening]
-~~~~~~~~~~~~~~~~~
-As described in "Closed type families with overlapping equations"
-http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf
-we need to flatten core types before unifying them, when checking for "surely-apart"
-against earlier equations of a closed type family.
-Flattening means replacing all top-level uses of type functions with
-fresh variables, *taking care to preserve sharing*. That is, the type
-(Either (F a b) (F a b)) should flatten to (Either c c), never (Either
-c d).
-
-Here is a nice example of why it's all necessary:
-
-  type family F a b where
-    F Int Bool = Char
-    F a   b    = Double
-  type family G a         -- open, no instances
-
-How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,
-while the second equation does. But, before reducing, we must make sure that the
-target can never become (F Int Bool). Well, no matter what G Float becomes, it
-certainly won't become *both* Int and Bool, so indeed we're safe reducing
-(F (G Float) (G Float)) to Double.
-
-This is necessary not only to get more reductions (which we might be
-willing to give up on), but for substitutivity. If we have (F x x), we
-can see that (F x x) can reduce to Double. So, it had better be the
-case that (F blah blah) can reduce to Double, no matter what (blah)
-is!  Flattening as done below ensures this.
-
-The algorithm works by building up a TypeMap TyVar, mapping
-type family applications to fresh variables. This mapping must
-be threaded through all the function calls, as any entry in
-the mapping must be propagated to all future nodes in the tree.
-
-The algorithm also must track the set of in-scope variables, in
-order to make fresh variables as it flattens. (We are far from a
-source of fresh Uniques.) See Wrinkle 2, below.
-
-There are wrinkles, of course:
-
-1. The flattening algorithm must account for the possibility
-   of inner `forall`s. (A `forall` seen here can happen only
-   because of impredicativity. However, the flattening operation
-   is an algorithm in Core, which is impredicative.)
-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,
-   those two bs are entirely unrelated, and so we should certainly
-   not flatten the two calls F b to the same variable. Instead, they
-   must be treated separately. We thus carry a substitution that
-   freshens variables; we must apply this substitution (in
-   `coreFlattenTyFamApp`) before looking up an application in the environment.
-   Note that the range of the substitution contains only TyVars, never anything
-   else.
-
-   For the sake of efficiency, we only apply this substitution when absolutely
-   necessary. Namely:
-
-   * We do not perform the substitution at all if it is empty.
-   * We only need to worry about the arguments of a type family that are within
-     the arity of said type family, so we can get away with not applying the
-     substitution to any oversaturated type family arguments.
-   * Importantly, we do /not/ achieve this substitution by recursively
-     flattening the arguments, as this would be wrong. Consider `F (G a)`,
-     where F and G are type families. We might decide that `F (G a)` flattens
-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and
-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,
-     `F gamma` is unknown, and so we flatten it to `delta`, but it really
-     should have been `beta`! Argh!
-
-     Moral of the story: instead of flattening the arguments, just substitute
-     them directly.
-
-2. There are two different reasons we might add a variable
-   to the in-scope set as we work:
-
-     A. We have just invented a new flattening variable.
-     B. We have entered a `forall`.
-
-   Annoying here is that in-scope variable source (A) must be
-   threaded through the calls. For example, consider (F b -> forall c. F c).
-   Suppose that, when flattening F b, we invent a fresh variable c.
-   Now, when we encounter (forall c. F c), we need to know c is already in
-   scope so that we locally rename c to c'. However, if we don't thread through
-   the in-scope set from one argument of (->) to the other, we won't know this
-   and might get very confused.
-
-   In contrast, source (B) increases only as we go deeper, as in-scope sets
-   normally do. However, even here we must be careful. The TypeMap TyVar that
-   contains mappings from type family applications to freshened variables will
-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We
-   thus must make sure that the two `b`s don't get renamed to the same b1. (If
-   they did, then looking up `F b1` would yield the same flatten var for
-   each.) So, even though `forall`-bound variables should really be in the
-   in-scope set only when they are in scope, we retain these variables even
-   outside of their scope. This ensures that, if we encounter a fresh
-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a
-   larger in-scope set than strictly necessary is always OK, as in-scope sets
-   are only ever used to avoid collisions.
-
-   Sadly, the freshening substitution described in (1) really mustn't bind
-   variables outside of their scope: note that its domain is the *unrenamed*
-   variables. This means that the substitution gets "pushed down" (like a
-   reader monad) while the in-scope set gets threaded (like a state monad).
-   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;
-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet
-   traveling separately as necessary.
-
-3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:
-
-     type family F ty_1 ... ty_k :: res_k
-
-   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a
-   flattening skolem. But we must instead flatten it to
-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the
-   type family.
-
-   Why is this better? Consider the following concrete example from #16995:
-
-     type family Param :: Type -> Type
-
-     type family LookupParam (a :: Type) :: Type where
-       LookupParam (f Char) = Bool
-       LookupParam x        = Int
-
-     foo :: LookupParam (Param ())
-     foo = 42
-
-   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to
-   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if
-   `alpha` is apart from `f Char`, so it won't fall through to the second
-   equation. But since the `Param` type family has arity 0, we can instead
-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is
-   apart from `f Char`, permitting the second equation to be reached.
-
-   Not only does this allow more programs to be accepted, it's also important
-   for correctness. Not doing this was the root cause of the Core Lint error
-   in #16995.
-
-flattenTys is defined here because of module dependencies.
--}
-
-data FlattenEnv
-  = FlattenEnv { fe_type_map :: TypeMap TyVar
-                 -- domain: exactly-saturated type family applications
-                 -- range: fresh variables
-               , fe_in_scope :: InScopeSet }
-                 -- See Note [Flattening]
-
-emptyFlattenEnv :: InScopeSet -> FlattenEnv
-emptyFlattenEnv in_scope
-  = FlattenEnv { fe_type_map = emptyTypeMap
-               , fe_in_scope = in_scope }
-
-updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv
-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }
-
-flattenTys :: InScopeSet -> [Type] -> [Type]
--- See Note [Flattening]
--- NB: the returned types may mention fresh type variables,
---     arising from the flattening.  We don't return the
---     mapping from those fresh vars to the ty-fam
---     applications they stand for (we could, but no need)
-flattenTys in_scope tys
-  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys
-
-coreFlattenTys :: TvSubstEnv -> FlattenEnv
-               -> [Type] -> (FlattenEnv, [Type])
-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)
-
-coreFlattenTy :: TvSubstEnv -> FlattenEnv
-              -> Type -> (FlattenEnv, Type)
-coreFlattenTy subst = go
-  where
-    go env ty | Just ty' <- coreView ty = go env ty'
-
-    go env (TyVarTy tv)
-      | Just ty <- lookupVarEnv subst tv = (env, ty)
-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in
-                                           (env', mkTyVarTy $ setTyVarKind tv ki)
-    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1
-                                 (env2, ty2') = go env1 ty2 in
-                             (env2, AppTy ty1' ty2')
-    go env (TyConApp tc tys)
-         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,
-         -- which are generative and thus can be preserved during flattening
-      | not (isGenerativeTyCon tc Nominal)
-      = coreFlattenTyFamApp subst env tc tys
-
-      | otherwise
-      = let (env', tys') = coreFlattenTys subst env tys in
-        (env', mkTyConApp tc tys')
-
-    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
-      = let (env1, ty1') = go env  ty1
-            (env2, ty2') = go env1 ty2
-            (env3, mult') = go env2 mult in
-        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })
-
-    go env (ForAllTy (Bndr tv vis) ty)
-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv
-            (env2, ty') = coreFlattenTy subst' env1 ty in
-        (env2, ForAllTy (Bndr tv' vis) ty')
-
-    go env ty@(LitTy {}) = (env, ty)
-
-    go env (CastTy ty co)
-      = let (env1, ty') = go env ty
-            (env2, co') = coreFlattenCo subst env1 co in
-        (env2, CastTy ty' co')
-
-    go env (CoercionTy co)
-      = let (env', co') = coreFlattenCo subst env co in
-        (env', CoercionTy co')
-
-
--- when flattening, we don't care about the contents of coercions.
--- so, just return a fresh variable of the right (flattened) type
-coreFlattenCo :: TvSubstEnv -> FlattenEnv
-              -> Coercion -> (FlattenEnv, Coercion)
-coreFlattenCo subst env co
-  = (env2, mkCoVarCo covar)
-  where
-    (env1, kind') = coreFlattenTy subst env (coercionType co)
-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'
-    -- Add the covar to the FlattenEnv's in-scope set.
-    -- See Note [Flattening], wrinkle 2A.
-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)
-
-coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv
-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)
-coreFlattenVarBndr subst env tv
-  = (env2, subst', tv')
-  where
-    -- See Note [Flattening], wrinkle 2B.
-    kind          = varType tv
-    (env1, kind') = coreFlattenTy subst env kind
-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')
-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')
-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')
-
-coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv
-                    -> TyCon         -- type family tycon
-                    -> [Type]        -- args, already flattened
-                    -> (FlattenEnv, Type)
-coreFlattenTyFamApp tv_subst env fam_tc fam_args
-  = case lookupTypeMap type_map fam_ty of
-      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')
-      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc
-                     tv         = uniqAway in_scope $
-                                  mkTyVar tyvar_name (typeKind fam_ty)
-
-                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'
-                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv
-                                  , fe_in_scope = extendInScopeSet in_scope tv }
-                 in (env'', ty')
-  where
-    arity = tyConArity fam_tc
-    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv
-    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )
-                                    splitAt arity fam_args
-    -- Apply the substitution before looking up an application in the
-    -- environment. See Note [Flattening], wrinkle 1.
-    -- NB: substTys short-cuts the common case when the substitution is empty.
-    sat_fam_args' = substTys tcv_subst sat_fam_args
-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args
-    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],
-    -- wrinkle 3), so we split it into the arguments needed to saturate it
-    -- (sat_fam_args') and the rest (leftover_args')
-    fam_ty = mkTyConApp fam_tc sat_fam_args'
-    FlattenEnv { fe_type_map = type_map
-               , fe_in_scope = in_scope } = env'
-
-mkFlattenFreshTyName :: Uniquable a => a -> Name
-mkFlattenFreshTyName unq
-  = mkSysTvName (getUnique unq) (fsLit "flt")
-
-mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar
-mkFlattenFreshCoVar in_scope kind
-  = let uniq = unsafeGetFreshLocalUnique in_scope
-        name = mkSystemVarName uniq (fsLit "flc")
-    in mkCoVar name kind
diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs
new file mode 100644
index 0000000000..b3273a1a2e
--- /dev/null
+++ b/compiler/GHC/Core/Map/Expr.hs
@@ -0,0 +1,369 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)
+
+module GHC.Core.Map.Expr (
+   -- * Maps over Core expressions
+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
+   -- * 'TrieMap' class reexports
+   TrieMap(..), insertTM, deleteTM,
+   lkDFreeVar, xtDFreeVar,
+   lkDNamed, xtDNamed,
+   (>.>), (|>), (|>>),
+ ) where
+
+#include "HsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Data.TrieMap
+import GHC.Core.Map.Type
+import GHC.Core
+import GHC.Core.Type
+import GHC.Types.Var
+
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+
+import qualified Data.Map    as Map
+import GHC.Types.Name.Env
+import Control.Monad( (>=>) )
+
+{-
+This module implements TrieMaps over Core related data structures
+like CoreExpr or Type. It is built on the Tries from the TrieMap
+module.
+
+The code is very regular and boilerplate-like, but there is
+some neat handling of *binders*.  In effect they are deBruijn
+numbered on the fly.
+
+
+-}
+
+----------------------
+-- Recall that
+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
+
+-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not
+-- known when defining GenMap so we can only specialize them here.
+
+{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}
+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}
+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}
+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}
+
+
+{-
+************************************************************************
+*                                                                      *
+                   CoreMap
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [Binders]
+~~~~~~~~~~~~~~
+ * In general we check binders as late as possible because types are
+   less likely to differ than expression structure.  That's why
+      cm_lam :: CoreMapG (TypeMapG a)
+   rather than
+      cm_lam :: TypeMapG (CoreMapG a)
+
+ * We don't need to look at the type of some binders, notably
+     - the case binder in (Case _ b _ _)
+     - the binders in an alternative
+   because they are totally fixed by the context
+
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* For a key (Case e b ty (alt:alts))  we don't need to look the return type
+  'ty', because every alternative has that type.
+
+* For a key (Case e b ty []) we MUST look at the return type 'ty', because
+  otherwise (Case (error () "urk") _ Int  []) would compare equal to
+            (Case (error () "urk") _ Bool [])
+  which is utterly wrong (#6097)
+
+We could compare the return type regardless, but the wildly common case
+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)
+for the two possibilities.  Only cm_ecase looks at the type.
+
+See also Note [Empty case alternatives] in GHC.Core.
+-}
+
+-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this
+-- is the type you want.
+newtype CoreMap a = CoreMap (CoreMapG a)
+
+instance TrieMap CoreMap where
+    type Key CoreMap = CoreExpr
+    emptyTM = CoreMap emptyTM
+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
+    foldTM k (CoreMap m) = foldTM k m
+    mapTM f (CoreMap m) = CoreMap (mapTM f m)
+
+-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended
+-- key makes it suitable for recursive traversal, since it can track binders,
+-- but it is strictly internal to this module.  If you are including a 'CoreMap'
+-- inside another 'TrieMap', this is the type you want.
+type CoreMapG = GenMap CoreMapX
+
+-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
+-- the 'GenMap' optimization.
+data CoreMapX a
+  = CM { cm_var   :: VarMap a
+       , cm_lit   :: LiteralMap a
+       , cm_co    :: CoercionMapG a
+       , cm_type  :: TypeMapG a
+       , cm_cast  :: CoreMapG (CoercionMapG a)
+       , cm_tick  :: CoreMapG (TickishMap a)
+       , cm_app   :: CoreMapG (CoreMapG a)
+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]
+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))
+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))
+       , cm_case  :: CoreMapG (ListMap AltMap a)
+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]
+     }
+
+instance Eq (DeBruijn CoreExpr) where
+  D env1 e1 == D env2 e2 = go e1 e2 where
+    go (Var v1) (Var v2)
+      = case (lookupCME env1 v1, lookupCME env2 v2) of
+                            (Just b1, Just b2) -> b1 == b2
+                            (Nothing, Nothing) -> v1 == v2
+                            _ -> False
+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2
+    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2
+    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2
+    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2
+    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2
+    -- This seems a bit dodgy, see 'eqTickish'
+    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2
+
+    go (Lam b1 e1)  (Lam b2 e2)
+      =  D env1 (varType b1) == D env2 (varType b2)
+      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)
+      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2
+
+    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
+      =  go r1 r2
+      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
+
+    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
+      = equalLength ps1 ps2
+      && D env1' rs1 == D env2' rs2
+      && D env1' e1  == D env2' e2
+      where
+        (bs1,rs1) = unzip ps1
+        (bs2,rs2) = unzip ps2
+        env1' = extendCMEs env1 bs1
+        env2' = extendCMEs env2 bs2
+
+    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
+      | null a1   -- See Note [Empty case alternatives]
+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2
+      | otherwise
+      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2
+
+    go _ _ = False
+
+emptyE :: CoreMapX a
+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
+            , cm_co = emptyTM, cm_type = emptyTM
+            , cm_cast = emptyTM, cm_app = emptyTM
+            , cm_lam = emptyTM, cm_letn = emptyTM
+            , cm_letr = emptyTM, cm_case = emptyTM
+            , cm_ecase = emptyTM, cm_tick = emptyTM }
+
+instance TrieMap CoreMapX where
+   type Key CoreMapX = DeBruijn CoreExpr
+   emptyTM  = emptyE
+   lookupTM = lkE
+   alterTM  = xtE
+   foldTM   = fdE
+   mapTM    = mapE
+
+--------------------------
+mapE :: (a->b) -> CoreMapX a -> CoreMapX b
+mapE f (CM { cm_var = cvar, cm_lit = clit
+           , cm_co = cco, cm_type = ctype
+           , cm_cast = ccast , cm_app = capp
+           , cm_lam = clam, cm_letn = cletn
+           , cm_letr = cletr, cm_case = ccase
+           , cm_ecase = cecase, cm_tick = ctick })
+  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
+       , cm_co = mapTM f cco, cm_type = mapTM f ctype
+       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
+       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
+       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
+       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
+
+--------------------------
+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
+lookupCoreMap cm e = lookupTM e cm
+
+extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a
+extendCoreMap m e v = alterTM e (\_ -> Just v) m
+
+foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b
+foldCoreMap k z m = foldTM k m z
+
+emptyCoreMap :: CoreMap a
+emptyCoreMap = emptyTM
+
+instance Outputable a => Outputable (CoreMap a) where
+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])
+
+-------------------------
+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b
+fdE k m
+  = foldTM k (cm_var m)
+  . foldTM k (cm_lit m)
+  . foldTM k (cm_co m)
+  . foldTM k (cm_type m)
+  . foldTM (foldTM k) (cm_cast m)
+  . foldTM (foldTM k) (cm_tick m)
+  . foldTM (foldTM k) (cm_app m)
+  . foldTM (foldTM k) (cm_lam m)
+  . foldTM (foldTM (foldTM k)) (cm_letn m)
+  . foldTM (foldTM (foldTM k)) (cm_letr m)
+  . foldTM (foldTM k) (cm_case m)
+  . foldTM (foldTM k) (cm_ecase m)
+
+-- lkE: lookup in trie for expressions
+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a
+lkE (D env expr) cm = go expr cm
+  where
+    go (Var v)              = cm_var  >.> lkVar env v
+    go (Lit l)              = cm_lit  >.> lookupTM l
+    go (Type t)             = cm_type >.> lkG (D env t)
+    go (Coercion c)         = cm_co   >.> lkG (D env c)
+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)
+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish
+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)
+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)
+                              >=> lkBndr env v
+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)
+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b
+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs
+                                  env1 = extendCMEs env bndrs
+                              in cm_letr
+                                 >.> lkList (lkG . D env1) rhss
+                                 >=> lkG (D env1 e)
+                                 >=> lkList (lkBndr env1) bndrs
+    go (Case e b ty as)     -- See Note [Empty case alternatives]
+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)
+               | otherwise  = cm_case >.> lkG (D env e)
+                              >=> lkList (lkA (extendCME env b)) as
+
+xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a
+xtE (D env (Var v))              f m = m { cm_var  = cm_var m
+                                                 |> xtVar env v f }
+xtE (D env (Type t))             f m = m { cm_type = cm_type m
+                                                 |> xtG (D env t) f }
+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m
+                                                 |> xtG (D env c) f }
+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }
+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)
+                                                 |>> xtG (D env c) f }
+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)
+                                                 |>> xtTickish t f }
+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)
+                                                 |>> xtG (D env e1) f }
+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m
+                                                 |> xtG (D (extendCME env v) e)
+                                                 |>> xtBndr env v f }
+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m
+                                                 |> xtG (D (extendCME env b) e)
+                                                 |>> xtG (D env r)
+                                                 |>> xtBndr env b f }
+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =
+                                              let (bndrs,rhss) = unzip prs
+                                                  env1 = extendCMEs env bndrs
+                                              in cm_letr m
+                                                 |>  xtList (xtG . D env1) rhss
+                                                 |>> xtG (D env1 e)
+                                                 |>> xtList (xtBndr env1)
+                                                            bndrs f }
+xtE (D env (Case e b ty as))     f m
+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)
+                                                 |>> xtG (D env ty) f }
+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)
+                                                 |>> let env1 = extendCME env b
+                                                     in xtList (xtA env1) as f }
+
+-- TODO: this seems a bit dodgy, see 'eqTickish'
+type TickishMap a = Map.Map (Tickish Id) a
+lkTickish :: Tickish Id -> TickishMap a -> Maybe a
+lkTickish = lookupTM
+
+xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a
+xtTickish = alterTM
+
+------------------------
+data AltMap a   -- A single alternative
+  = AM { am_deflt :: CoreMapG a
+       , am_data  :: DNameEnv (CoreMapG a)
+       , am_lit   :: LiteralMap (CoreMapG a) }
+
+instance TrieMap AltMap where
+   type Key AltMap = CoreAlt
+   emptyTM  = AM { am_deflt = emptyTM
+                 , am_data = emptyDNameEnv
+                 , am_lit  = emptyTM }
+   lookupTM = lkA emptyCME
+   alterTM  = xtA emptyCME
+   foldTM   = fdA
+   mapTM    = mapA
+
+instance Eq (DeBruijn CoreAlt) where
+  D env1 a1 == D env2 a2 = go a1 a2 where
+    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)
+        = D env1 rhs1 == D env2 rhs2
+    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)
+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2
+    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)
+        = dc1 == dc2 &&
+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
+    go _ _ = False
+
+mapA :: (a->b) -> AltMap a -> AltMap b
+mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
+  = AM { am_deflt = mapTM f adeflt
+       , am_data = mapTM (mapTM f) adata
+       , am_lit = mapTM (mapTM f) alit }
+
+lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
+lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)
+lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)
+lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc
+                                        >=> lkG (D (extendCMEs env bs) rhs)
+
+xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a
+xtA env (DEFAULT, _, rhs)    f m =
+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }
+xtA env (LitAlt l, _, rhs)   f m =
+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }
+xtA env (DataAlt d, bs, rhs) f m =
+    m { am_data  = am_data m  |> xtDNamed d
+                             |>> xtG (D (extendCMEs env bs) rhs) f }
+
+fdA :: (a -> b -> b) -> AltMap a -> b -> b
+fdA k m = foldTM k (am_deflt m)
+        . foldTM (foldTM k) (am_data m)
+        . foldTM (foldTM k) (am_lit m)
diff --git a/compiler/GHC/Core/Map.hs b/compiler/GHC/Core/Map/Type.hs
index d053aecb82..36583dc670 100644
--- a/compiler/GHC/Core/Map.hs
+++ b/compiler/GHC/Core/Map/Type.hs
@@ -1,412 +1,71 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
 {-
 (c) The University of Glasgow 2006
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 -}
 
-module GHC.Core.Map (
-   -- * Maps over Core expressions
-   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
-   -- * Maps over 'Type's
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module GHC.Core.Map.Type (
+     -- * Maps over 'Type's
    TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,
    LooseTypeMap,
    -- ** With explicit scoping
    CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,
-   mkDeBruijnContext,
-   -- * Maps over 'Maybe' values
-   MaybeMap,
-   -- * Maps over 'List' values
-   ListMap,
-   -- * Maps over 'Literal's
-   LiteralMap,
-   -- * Map for compressing leaves. See Note [Compressed TrieMap]
-   GenMap,
-   -- * 'TrieMap' class
-   TrieMap(..), insertTM, deleteTM,
-   lkDFreeVar, xtDFreeVar,
-   lkDNamed, xtDNamed,
-   (>.>), (|>), (|>>),
- ) where
-
-#include "HsVersions.h"
+   mkDeBruijnContext, extendCME, extendCMEs, emptyCME,
+
+   -- * Utilities for use by friends only
+   TypeMapG, CoercionMapG,
+
+   DeBruijn(..), deBruijnize,
+
+   BndrMap, xtBndr, lkBndr,
+   VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar,
+
+   xtDNamed, lkDNamed
+
+   ) where
+
+-- This module is separate from GHC.Core.Map.Expr to avoid a module loop
+-- between GHC.Core.Unify (which depends on this module) and GHC.Core
 
 import GHC.Prelude
 
-import GHC.Data.TrieMap
-import GHC.Core
-import GHC.Core.Coercion
-import GHC.Types.Name
 import GHC.Core.Type
+import GHC.Core.Coercion
 import GHC.Core.TyCo.Rep
-import GHC.Types.Var
-import GHC.Data.FastString(FastString)
+import GHC.Data.TrieMap
 
-import GHC.Utils.Misc
+import GHC.Data.FastString
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Types.Var
+import GHC.Types.Var.Env
+import GHC.Types.Unique.FM
 import GHC.Utils.Outputable
+
 import GHC.Utils.Panic
 
 import qualified Data.Map    as Map
 import qualified Data.IntMap as IntMap
-import GHC.Types.Unique.FM
-import GHC.Types.Var.Env
-import GHC.Types.Name.Env
-import Control.Monad( (>=>) )
-
-{-
-This module implements TrieMaps over Core related data structures
-like CoreExpr or Type. It is built on the Tries from the TrieMap
-module.
-
-The code is very regular and boilerplate-like, but there is
-some neat handling of *binders*.  In effect they are deBruijn
-numbered on the fly.
-
-
--}
 
-----------------------
--- Recall that
---   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
+import Control.Monad ( (>=>) )
 
 -- NB: Be careful about RULES and type families (#5821).  So we should make sure
 -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)
 
--- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not
--- known when defining GenMap so we can only specialize them here.
-
 {-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}
 {-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}
-{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}
-
 
 {-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}
 {-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}
-{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}
 
 {-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}
 {-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}
-{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}
 
 {-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}
 {-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}
-{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}
-
-
-{-
-************************************************************************
-*                                                                      *
-                   CoreMap
-*                                                                      *
-************************************************************************
--}
-
-lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
-lkDNamed n env = lookupDNameEnv env (getName n)
-
-xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a
-xtDNamed tc f m = alterDNameEnv f m (getName tc)
-
-
-{-
-Note [Binders]
-~~~~~~~~~~~~~~
- * In general we check binders as late as possible because types are
-   less likely to differ than expression structure.  That's why
-      cm_lam :: CoreMapG (TypeMapG a)
-   rather than
-      cm_lam :: TypeMapG (CoreMapG a)
-
- * We don't need to look at the type of some binders, notably
-     - the case binder in (Case _ b _ _)
-     - the binders in an alternative
-   because they are totally fixed by the context
-
-Note [Empty case alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* For a key (Case e b ty (alt:alts))  we don't need to look the return type
-  'ty', because every alternative has that type.
-
-* For a key (Case e b ty []) we MUST look at the return type 'ty', because
-  otherwise (Case (error () "urk") _ Int  []) would compare equal to
-            (Case (error () "urk") _ Bool [])
-  which is utterly wrong (#6097)
-
-We could compare the return type regardless, but the wildly common case
-is that it's unnecessary, so we have two fields (cm_case and cm_ecase)
-for the two possibilities.  Only cm_ecase looks at the type.
-
-See also Note [Empty case alternatives] in GHC.Core.
--}
-
--- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this
--- is the type you want.
-newtype CoreMap a = CoreMap (CoreMapG a)
-
-instance TrieMap CoreMap where
-    type Key CoreMap = CoreExpr
-    emptyTM = CoreMap emptyTM
-    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
-    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
-    foldTM k (CoreMap m) = foldTM k m
-    mapTM f (CoreMap m) = CoreMap (mapTM f m)
-
--- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended
--- key makes it suitable for recursive traversal, since it can track binders,
--- but it is strictly internal to this module.  If you are including a 'CoreMap'
--- inside another 'TrieMap', this is the type you want.
-type CoreMapG = GenMap CoreMapX
-
--- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
--- the 'GenMap' optimization.
-data CoreMapX a
-  = CM { cm_var   :: VarMap a
-       , cm_lit   :: LiteralMap a
-       , cm_co    :: CoercionMapG a
-       , cm_type  :: TypeMapG a
-       , cm_cast  :: CoreMapG (CoercionMapG a)
-       , cm_tick  :: CoreMapG (TickishMap a)
-       , cm_app   :: CoreMapG (CoreMapG a)
-       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]
-       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))
-       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))
-       , cm_case  :: CoreMapG (ListMap AltMap a)
-       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]
-     }
-
-instance Eq (DeBruijn CoreExpr) where
-  D env1 e1 == D env2 e2 = go e1 e2 where
-    go (Var v1) (Var v2)
-      = case (lookupCME env1 v1, lookupCME env2 v2) of
-                            (Just b1, Just b2) -> b1 == b2
-                            (Nothing, Nothing) -> v1 == v2
-                            _ -> False
-    go (Lit lit1)    (Lit lit2)      = lit1 == lit2
-    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2
-    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2
-    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2
-    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2
-    -- This seems a bit dodgy, see 'eqTickish'
-    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2
-
-    go (Lam b1 e1)  (Lam b2 e2)
-      =  D env1 (varType b1) == D env2 (varType b2)
-      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)
-      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2
-
-    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
-      =  go r1 r2
-      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
-
-    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
-      = equalLength ps1 ps2
-      && D env1' rs1 == D env2' rs2
-      && D env1' e1  == D env2' e2
-      where
-        (bs1,rs1) = unzip ps1
-        (bs2,rs2) = unzip ps2
-        env1' = extendCMEs env1 bs1
-        env2' = extendCMEs env2 bs2
-
-    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
-      | null a1   -- See Note [Empty case alternatives]
-      = null a2 && go e1 e2 && D env1 t1 == D env2 t2
-      | otherwise
-      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2
-
-    go _ _ = False
-
-emptyE :: CoreMapX a
-emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
-            , cm_co = emptyTM, cm_type = emptyTM
-            , cm_cast = emptyTM, cm_app = emptyTM
-            , cm_lam = emptyTM, cm_letn = emptyTM
-            , cm_letr = emptyTM, cm_case = emptyTM
-            , cm_ecase = emptyTM, cm_tick = emptyTM }
-
-instance TrieMap CoreMapX where
-   type Key CoreMapX = DeBruijn CoreExpr
-   emptyTM  = emptyE
-   lookupTM = lkE
-   alterTM  = xtE
-   foldTM   = fdE
-   mapTM    = mapE
-
---------------------------
-mapE :: (a->b) -> CoreMapX a -> CoreMapX b
-mapE f (CM { cm_var = cvar, cm_lit = clit
-           , cm_co = cco, cm_type = ctype
-           , cm_cast = ccast , cm_app = capp
-           , cm_lam = clam, cm_letn = cletn
-           , cm_letr = cletr, cm_case = ccase
-           , cm_ecase = cecase, cm_tick = ctick })
-  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
-       , cm_co = mapTM f cco, cm_type = mapTM f ctype
-       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
-       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
-       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
-       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
-
---------------------------
-lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
-lookupCoreMap cm e = lookupTM e cm
-
-extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a
-extendCoreMap m e v = alterTM e (\_ -> Just v) m
-
-foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b
-foldCoreMap k z m = foldTM k m z
-
-emptyCoreMap :: CoreMap a
-emptyCoreMap = emptyTM
-
-instance Outputable a => Outputable (CoreMap a) where
-  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])
-
--------------------------
-fdE :: (a -> b -> b) -> CoreMapX a -> b -> b
-fdE k m
-  = foldTM k (cm_var m)
-  . foldTM k (cm_lit m)
-  . foldTM k (cm_co m)
-  . foldTM k (cm_type m)
-  . foldTM (foldTM k) (cm_cast m)
-  . foldTM (foldTM k) (cm_tick m)
-  . foldTM (foldTM k) (cm_app m)
-  . foldTM (foldTM k) (cm_lam m)
-  . foldTM (foldTM (foldTM k)) (cm_letn m)
-  . foldTM (foldTM (foldTM k)) (cm_letr m)
-  . foldTM (foldTM k) (cm_case m)
-  . foldTM (foldTM k) (cm_ecase m)
-
--- lkE: lookup in trie for expressions
-lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a
-lkE (D env expr) cm = go expr cm
-  where
-    go (Var v)              = cm_var  >.> lkVar env v
-    go (Lit l)              = cm_lit  >.> lookupTM l
-    go (Type t)             = cm_type >.> lkG (D env t)
-    go (Coercion c)         = cm_co   >.> lkG (D env c)
-    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)
-    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish
-    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)
-    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)
-                              >=> lkBndr env v
-    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)
-                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b
-    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs
-                                  env1 = extendCMEs env bndrs
-                              in cm_letr
-                                 >.> lkList (lkG . D env1) rhss
-                                 >=> lkG (D env1 e)
-                                 >=> lkList (lkBndr env1) bndrs
-    go (Case e b ty as)     -- See Note [Empty case alternatives]
-               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)
-               | otherwise  = cm_case >.> lkG (D env e)
-                              >=> lkList (lkA (extendCME env b)) as
-
-xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a
-xtE (D env (Var v))              f m = m { cm_var  = cm_var m
-                                                 |> xtVar env v f }
-xtE (D env (Type t))             f m = m { cm_type = cm_type m
-                                                 |> xtG (D env t) f }
-xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m
-                                                 |> xtG (D env c) f }
-xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }
-xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)
-                                                 |>> xtG (D env c) f }
-xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)
-                                                 |>> xtTickish t f }
-xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)
-                                                 |>> xtG (D env e1) f }
-xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m
-                                                 |> xtG (D (extendCME env v) e)
-                                                 |>> xtBndr env v f }
-xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m
-                                                 |> xtG (D (extendCME env b) e)
-                                                 |>> xtG (D env r)
-                                                 |>> xtBndr env b f }
-xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =
-                                              let (bndrs,rhss) = unzip prs
-                                                  env1 = extendCMEs env bndrs
-                                              in cm_letr m
-                                                 |>  xtList (xtG . D env1) rhss
-                                                 |>> xtG (D env1 e)
-                                                 |>> xtList (xtBndr env1)
-                                                            bndrs f }
-xtE (D env (Case e b ty as))     f m
-                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)
-                                                 |>> xtG (D env ty) f }
-                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)
-                                                 |>> let env1 = extendCME env b
-                                                     in xtList (xtA env1) as f }
-
--- TODO: this seems a bit dodgy, see 'eqTickish'
-type TickishMap a = Map.Map (Tickish Id) a
-lkTickish :: Tickish Id -> TickishMap a -> Maybe a
-lkTickish = lookupTM
-
-xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a
-xtTickish = alterTM
-
-------------------------
-data AltMap a   -- A single alternative
-  = AM { am_deflt :: CoreMapG a
-       , am_data  :: DNameEnv (CoreMapG a)
-       , am_lit   :: LiteralMap (CoreMapG a) }
-
-instance TrieMap AltMap where
-   type Key AltMap = CoreAlt
-   emptyTM  = AM { am_deflt = emptyTM
-                 , am_data = emptyDNameEnv
-                 , am_lit  = emptyTM }
-   lookupTM = lkA emptyCME
-   alterTM  = xtA emptyCME
-   foldTM   = fdA
-   mapTM    = mapA
-
-instance Eq (DeBruijn CoreAlt) where
-  D env1 a1 == D env2 a2 = go a1 a2 where
-    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)
-        = D env1 rhs1 == D env2 rhs2
-    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)
-        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2
-    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)
-        = dc1 == dc2 &&
-          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
-    go _ _ = False
-
-mapA :: (a->b) -> AltMap a -> AltMap b
-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
-  = AM { am_deflt = mapTM f adeflt
-       , am_data = mapTM (mapTM f) adata
-       , am_lit = mapTM (mapTM f) alit }
-
-lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
-lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)
-lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)
-lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc
-                                        >=> lkG (D (extendCMEs env bs) rhs)
-
-xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a
-xtA env (DEFAULT, _, rhs)    f m =
-    m { am_deflt = am_deflt m |> xtG (D env rhs) f }
-xtA env (LitAlt l, _, rhs)   f m =
-    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }
-xtA env (DataAlt d, bs, rhs) f m =
-    m { am_data  = am_data m  |> xtDNamed d
-                             |>> xtG (D (extendCMEs env bs) rhs) f }
-
-fdA :: (a -> b -> b) -> AltMap a -> b -> b
-fdA k m = foldTM k (am_deflt m)
-        . foldTM (foldTM k) (am_data m)
-        . foldTM (foldTM k) (am_lit m)
 
 {-
 ************************************************************************
@@ -476,7 +135,7 @@ data TypeMapX a
   = TM { tm_var    :: VarMap a
        , tm_app    :: TypeMapG (TypeMapG a)
        , tm_tycon  :: DNameEnv a
-       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders]
+       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr
        , tm_tylit  :: TyLitMap a
        , tm_coerce :: Maybe a
        }
@@ -784,8 +443,6 @@ fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b
 fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm
 
 
--- Note [Binders]
--- ~~~~~~~~~~~~~~
 -- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all
 -- of these data types have binding forms.
 
@@ -835,3 +492,10 @@ lkDFreeVar var env = lookupDVarEnv env var
 
 xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a
 xtDFreeVar v f m = alterDVarEnv f m v
+
+-------------------------------------------------
+lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a
+lkDNamed n env = lookupDNameEnv env (getName n)
+
+xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a
+xtDNamed tc f m = alterDNameEnv f m (getName tc)
diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs
index 3f826621a6..537bd931af 100644
--- a/compiler/GHC/Core/Opt/CSE.hs
+++ b/compiler/GHC/Core/Opt/CSE.hs
@@ -30,7 +30,7 @@ import GHC.Core.Type    ( tyConAppArgs )
 import GHC.Core
 import GHC.Utils.Outputable
 import GHC.Types.Basic
-import GHC.Core.Map
+import GHC.Core.Map.Expr
 import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn )
 import GHC.Utils.Panic
 import Data.List        ( mapAccumL )
diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs
index 0bbc844189..c99913d3be 100644
--- a/compiler/GHC/Core/Unify.hs
+++ b/compiler/GHC/Core/Unify.hs
@@ -21,7 +21,10 @@ module GHC.Core.Unify (
         UnifyResult, UnifyResultM(..),
 
         -- Matching a type against a lifted type (coercion)
-        liftCoMatch
+        liftCoMatch,
+
+        -- The core flattening algorithm
+        flattenTys
    ) where
 
 #include "HsVersions.h"
@@ -31,21 +34,26 @@ import GHC.Prelude
 import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
-import GHC.Types.Name( Name )
+import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )
 import GHC.Core.Type     hiding ( getTvSubstEnv )
 import GHC.Core.Coercion hiding ( getCvSubstEnv )
 import GHC.Core.TyCon
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes )
 import GHC.Core.TyCo.Subst ( mkTvSubst )
+import GHC.Core.Map.Type
 import GHC.Utils.FV( FV, fvVarSet, fvVarList )
 import GHC.Utils.Misc
 import GHC.Data.Pair
 import GHC.Utils.Outputable
+import GHC.Types.Unique
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.Set
 import GHC.Exts( oneShot )
+import GHC.Utils.Panic
+import GHC.Data.FastString
 
+import Data.List ( mapAccumL )
 import Control.Monad
 import Control.Applicative hiding ( empty )
 import qualified Control.Applicative
@@ -691,7 +699,7 @@ unifier It does /not/ work up to ~.
 The algorithm implemented here is rather delicate, and we depend on it
 to uphold certain properties. This is a summary of these required
 properties. Any reference to "flattening" refers to the flattening
-algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not
+algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.Unify), not
 the flattening algorithm in the solver.
 
 Notation:
@@ -1600,3 +1608,292 @@ pushRefl co =
       -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))
     -- NB: NoRefl variant. Otherwise, we get a loop!
     _ -> Nothing
+
+{-
+************************************************************************
+*                                                                      *
+              Flattening
+*                                                                      *
+************************************************************************
+
+Note [Flattening]
+~~~~~~~~~~~~~~~~~
+As described in "Closed type families with overlapping equations"
+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf
+we need to flatten core types before unifying them, when checking for "surely-apart"
+against earlier equations of a closed type family.
+Flattening means replacing all top-level uses of type functions with
+fresh variables, *taking care to preserve sharing*. That is, the type
+(Either (F a b) (F a b)) should flatten to (Either c c), never (Either
+c d).
+
+Here is a nice example of why it's all necessary:
+
+  type family F a b where
+    F Int Bool = Char
+    F a   b    = Double
+  type family G a         -- open, no instances
+
+How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,
+while the second equation does. But, before reducing, we must make sure that the
+target can never become (F Int Bool). Well, no matter what G Float becomes, it
+certainly won't become *both* Int and Bool, so indeed we're safe reducing
+(F (G Float) (G Float)) to Double.
+
+This is necessary not only to get more reductions (which we might be
+willing to give up on), but for substitutivity. If we have (F x x), we
+can see that (F x x) can reduce to Double. So, it had better be the
+case that (F blah blah) can reduce to Double, no matter what (blah)
+is!  Flattening as done below ensures this.
+
+The algorithm works by building up a TypeMap TyVar, mapping
+type family applications to fresh variables. This mapping must
+be threaded through all the function calls, as any entry in
+the mapping must be propagated to all future nodes in the tree.
+
+The algorithm also must track the set of in-scope variables, in
+order to make fresh variables as it flattens. (We are far from a
+source of fresh Uniques.) See Wrinkle 2, below.
+
+There are wrinkles, of course:
+
+1. The flattening algorithm must account for the possibility
+   of inner `forall`s. (A `forall` seen here can happen only
+   because of impredicativity. However, the flattening operation
+   is an algorithm in Core, which is impredicative.)
+   Suppose we have (forall b. F b) -> (forall b. F b). Of course,
+   those two bs are entirely unrelated, and so we should certainly
+   not flatten the two calls F b to the same variable. Instead, they
+   must be treated separately. We thus carry a substitution that
+   freshens variables; we must apply this substitution (in
+   `coreFlattenTyFamApp`) before looking up an application in the environment.
+   Note that the range of the substitution contains only TyVars, never anything
+   else.
+
+   For the sake of efficiency, we only apply this substitution when absolutely
+   necessary. Namely:
+
+   * We do not perform the substitution at all if it is empty.
+   * We only need to worry about the arguments of a type family that are within
+     the arity of said type family, so we can get away with not applying the
+     substitution to any oversaturated type family arguments.
+   * Importantly, we do /not/ achieve this substitution by recursively
+     flattening the arguments, as this would be wrong. Consider `F (G a)`,
+     where F and G are type families. We might decide that `F (G a)` flattens
+     to `beta`. Later, the substitution is non-empty (but does not map `a`) and
+     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,
+     `F gamma` is unknown, and so we flatten it to `delta`, but it really
+     should have been `beta`! Argh!
+
+     Moral of the story: instead of flattening the arguments, just substitute
+     them directly.
+
+2. There are two different reasons we might add a variable
+   to the in-scope set as we work:
+
+     A. We have just invented a new flattening variable.
+     B. We have entered a `forall`.
+
+   Annoying here is that in-scope variable source (A) must be
+   threaded through the calls. For example, consider (F b -> forall c. F c).
+   Suppose that, when flattening F b, we invent a fresh variable c.
+   Now, when we encounter (forall c. F c), we need to know c is already in
+   scope so that we locally rename c to c'. However, if we don't thread through
+   the in-scope set from one argument of (->) to the other, we won't know this
+   and might get very confused.
+
+   In contrast, source (B) increases only as we go deeper, as in-scope sets
+   normally do. However, even here we must be careful. The TypeMap TyVar that
+   contains mappings from type family applications to freshened variables will
+   be threaded through both sides of (forall b. F b) -> (forall b. F b). We
+   thus must make sure that the two `b`s don't get renamed to the same b1. (If
+   they did, then looking up `F b1` would yield the same flatten var for
+   each.) So, even though `forall`-bound variables should really be in the
+   in-scope set only when they are in scope, we retain these variables even
+   outside of their scope. This ensures that, if we encounter a fresh
+   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a
+   larger in-scope set than strictly necessary is always OK, as in-scope sets
+   are only ever used to avoid collisions.
+
+   Sadly, the freshening substitution described in (1) really mustn't bind
+   variables outside of their scope: note that its domain is the *unrenamed*
+   variables. This means that the substitution gets "pushed down" (like a
+   reader monad) while the in-scope set gets threaded (like a state monad).
+   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;
+   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet
+   traveling separately as necessary.
+
+3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:
+
+     type family F ty_1 ... ty_k :: res_k
+
+   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a
+   flattening skolem. But we must instead flatten it to
+   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the
+   type family.
+
+   Why is this better? Consider the following concrete example from #16995:
+
+     type family Param :: Type -> Type
+
+     type family LookupParam (a :: Type) :: Type where
+       LookupParam (f Char) = Bool
+       LookupParam x        = Int
+
+     foo :: LookupParam (Param ())
+     foo = 42
+
+   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to
+   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if
+   `alpha` is apart from `f Char`, so it won't fall through to the second
+   equation. But since the `Param` type family has arity 0, we can instead
+   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is
+   apart from `f Char`, permitting the second equation to be reached.
+
+   Not only does this allow more programs to be accepted, it's also important
+   for correctness. Not doing this was the root cause of the Core Lint error
+   in #16995.
+
+flattenTys is defined here because of module dependencies.
+-}
+
+data FlattenEnv
+  = FlattenEnv { fe_type_map :: TypeMap TyVar
+                 -- domain: exactly-saturated type family applications
+                 -- range: fresh variables
+               , fe_in_scope :: InScopeSet }
+                 -- See Note [Flattening]
+
+emptyFlattenEnv :: InScopeSet -> FlattenEnv
+emptyFlattenEnv in_scope
+  = FlattenEnv { fe_type_map = emptyTypeMap
+               , fe_in_scope = in_scope }
+
+updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv
+updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }
+
+flattenTys :: InScopeSet -> [Type] -> [Type]
+-- See Note [Flattening]
+-- NB: the returned types may mention fresh type variables,
+--     arising from the flattening.  We don't return the
+--     mapping from those fresh vars to the ty-fam
+--     applications they stand for (we could, but no need)
+flattenTys in_scope tys
+  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys
+
+coreFlattenTys :: TvSubstEnv -> FlattenEnv
+               -> [Type] -> (FlattenEnv, [Type])
+coreFlattenTys subst = mapAccumL (coreFlattenTy subst)
+
+coreFlattenTy :: TvSubstEnv -> FlattenEnv
+              -> Type -> (FlattenEnv, Type)
+coreFlattenTy subst = go
+  where
+    go env ty | Just ty' <- coreView ty = go env ty'
+
+    go env (TyVarTy tv)
+      | Just ty <- lookupVarEnv subst tv = (env, ty)
+      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in
+                                           (env', mkTyVarTy $ setTyVarKind tv ki)
+    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1
+                                 (env2, ty2') = go env1 ty2 in
+                             (env2, AppTy ty1' ty2')
+    go env (TyConApp tc tys)
+         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,
+         -- which are generative and thus can be preserved during flattening
+      | not (isGenerativeTyCon tc Nominal)
+      = coreFlattenTyFamApp subst env tc tys
+
+      | otherwise
+      = let (env', tys') = coreFlattenTys subst env tys in
+        (env', mkTyConApp tc tys')
+
+    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
+      = let (env1, ty1') = go env  ty1
+            (env2, ty2') = go env1 ty2
+            (env3, mult') = go env2 mult in
+        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })
+
+    go env (ForAllTy (Bndr tv vis) ty)
+      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv
+            (env2, ty') = coreFlattenTy subst' env1 ty in
+        (env2, ForAllTy (Bndr tv' vis) ty')
+
+    go env ty@(LitTy {}) = (env, ty)
+
+    go env (CastTy ty co)
+      = let (env1, ty') = go env ty
+            (env2, co') = coreFlattenCo subst env1 co in
+        (env2, CastTy ty' co')
+
+    go env (CoercionTy co)
+      = let (env', co') = coreFlattenCo subst env co in
+        (env', CoercionTy co')
+
+
+-- when flattening, we don't care about the contents of coercions.
+-- so, just return a fresh variable of the right (flattened) type
+coreFlattenCo :: TvSubstEnv -> FlattenEnv
+              -> Coercion -> (FlattenEnv, Coercion)
+coreFlattenCo subst env co
+  = (env2, mkCoVarCo covar)
+  where
+    (env1, kind') = coreFlattenTy subst env (coercionType co)
+    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'
+    -- Add the covar to the FlattenEnv's in-scope set.
+    -- See Note [Flattening], wrinkle 2A.
+    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)
+
+coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv
+                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)
+coreFlattenVarBndr subst env tv
+  = (env2, subst', tv')
+  where
+    -- See Note [Flattening], wrinkle 2B.
+    kind          = varType tv
+    (env1, kind') = coreFlattenTy subst env kind
+    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')
+    subst'        = extendVarEnv subst tv (mkTyVarTy tv')
+    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')
+
+coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv
+                    -> TyCon         -- type family tycon
+                    -> [Type]        -- args, already flattened
+                    -> (FlattenEnv, Type)
+coreFlattenTyFamApp tv_subst env fam_tc fam_args
+  = case lookupTypeMap type_map fam_ty of
+      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')
+      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc
+                     tv         = uniqAway in_scope $
+                                  mkTyVar tyvar_name (typeKind fam_ty)
+
+                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'
+                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv
+                                  , fe_in_scope = extendInScopeSet in_scope tv }
+                 in (env'', ty')
+  where
+    arity = tyConArity fam_tc
+    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv
+    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )
+                                    splitAt arity fam_args
+    -- Apply the substitution before looking up an application in the
+    -- environment. See Note [Flattening], wrinkle 1.
+    -- NB: substTys short-cuts the common case when the substitution is empty.
+    sat_fam_args' = substTys tcv_subst sat_fam_args
+    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args
+    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],
+    -- wrinkle 3), so we split it into the arguments needed to saturate it
+    -- (sat_fam_args') and the rest (leftover_args')
+    fam_ty = mkTyConApp fam_tc sat_fam_args'
+    FlattenEnv { fe_type_map = type_map
+               , fe_in_scope = in_scope } = env'
+
+mkFlattenFreshTyName :: Uniquable a => a -> Name
+mkFlattenFreshTyName unq
+  = mkSysTvName (getUnique unq) (fsLit "flt")
+
+mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar
+mkFlattenFreshCoVar in_scope kind
+  = let uniq = unsafeGetFreshLocalUnique in_scope
+        name = mkSystemVarName uniq (fsLit "flc")
+    in mkCoVar name kind
diff --git a/compiler/GHC/Data/TrieMap.hs b/compiler/GHC/Data/TrieMap.hs
index 340828ee95..52a5b4ac78 100644
--- a/compiler/GHC/Data/TrieMap.hs
+++ b/compiler/GHC/Data/TrieMap.hs
@@ -46,7 +46,7 @@ whose key is a structured value like a CoreExpr or Type.
 
 This file implements tries over general data structures.
 Implementation for tries over Core Expressions/Types are
-available in GHC.Core.Map.
+available in GHC.Core.Map.Expr.
 
 The regular pattern for handling TrieMaps on data structures was first
 described (to my knowledge) in Connelly and Morris's 1995 paper "A
@@ -332,7 +332,7 @@ just use SingletonMap.
 nothing in the map, don't bother building out the (possibly infinite) recursive
 TrieMap structure!
 
-Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things
+Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things
 as INLINEABLE to permit specialization.
 -}
 
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
index 326b532325..3519f9250a 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver.hs
@@ -58,7 +58,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Core
 import GHC.Core.FVs       (exprFreeVars)
-import GHC.Core.Map
+import GHC.Core.Map.Expr
 import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
 import GHC.Core.Utils     (exprType)
 import GHC.Core.Make      (mkListExpr, mkCharExpr)
diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
index 3ff4b4cbb2..26a2eaef79 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs
@@ -54,7 +54,7 @@ import GHC.Core.Type
 import GHC.Core.TyCon
 import GHC.Types.Literal
 import GHC.Core
-import GHC.Core.Map
+import GHC.Core.Map.Expr
 import GHC.Core.Utils (exprType)
 import GHC.Builtin.Names
 import GHC.Builtin.Types
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 5166ddc6b2..c4c86dd216 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -8,7 +8,7 @@ module GHC.Iface.Ext.Utils where
 
 import GHC.Prelude
 
-import GHC.Core.Map
+import GHC.Core.Map.Type
 import GHC.Driver.Session    ( DynFlags )
 import GHC.Driver.Ppr
 import GHC.Data.FastString   ( FastString, mkFastString )
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
index 61362053f5..5a2b9b16fa 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ b/compiler/GHC/Stg/CSE.hs
@@ -102,7 +102,8 @@ import GHC.Types.Var.Env
 import GHC.Core (AltCon(..))
 import Data.List (mapAccumL)
 import Data.Maybe (fromMaybe)
-import GHC.Core.Map
+import GHC.Core.Map.Expr
+import GHC.Data.TrieMap
 import GHC.Types.Name.Env
 import Control.Monad( (>=>) )
 
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 37dc095f71..028d9b16a6 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -30,10 +30,9 @@ import GHC.Core.Type
 import GHC.Core.Coercion
 import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )
-import GHC.Core.Unify     ( tcMatchTys )
+import GHC.Core.Unify     ( tcMatchTys, flattenTys )
 import GHC.Unit.Module
 import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv ( flattenTys )
 import GHC.Tc.Utils.Instantiate
 import GHC.Core.InstEnv
 import GHC.Core.TyCon
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
index 01f18a7d6b..e4eb7a1b2d 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ b/compiler/GHC/Tc/Instance/Typeable.hs
@@ -40,7 +40,7 @@ import GHC.Hs
 import GHC.Driver.Session
 import GHC.Data.Bag
 import GHC.Types.Var ( VarBndr(..) )
-import GHC.Core.Map
+import GHC.Core.Map.Type
 import GHC.Settings.Constants
 import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
 import GHC.Utils.Outputable
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 311eadc72e..64a80b2e94 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -178,7 +178,9 @@ import GHC.Types.Unique.DFM
 import GHC.Core.TyCon.Env
 import GHC.Data.Maybe
 
-import GHC.Core.Map
+import GHC.Core.Map.Type
+import GHC.Data.TrieMap
+
 import Control.Monad
 import GHC.Utils.Monad
 import Data.IORef
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 1195fa6cbc..ffee979a90 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -298,7 +298,8 @@ Library
         GHC.Core.InstEnv
         GHC.Core.Lint
         GHC.Core.Make
-        GHC.Core.Map
+        GHC.Core.Map.Expr
+        GHC.Core.Map.Type
         GHC.Core.Multiplicity
         GHC.Core.Opt.Arity
         GHC.Core.Opt.CallArity
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout
index 5fbdf896ee..97b7dc743f 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.stdout
+++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout
@@ -31,7 +31,7 @@ GHC.Core.FamInstEnv
 GHC.Core.InstEnv
 GHC.Core.Lint
 GHC.Core.Make
-GHC.Core.Map
+GHC.Core.Map.Type
 GHC.Core.Multiplicity
 GHC.Core.Opt.Arity
 GHC.Core.Opt.CallerCC