Apply some tricks to speed up core lint.wip/andreask/opt-core-lint

Below are the noteworthy changes and if given their impact on compiler
allocations for a type heavy module:

* Use the oneShot trick on LintM
* Use a unboxed tuple for the result of LintM: ~6% reduction
* Avoid a thunk for the result of typeKind in lintType: ~5% reduction
* lint_app: Don't allocate the error msg in the hot code path: ~4%
  reduction
* lint_app: Eagerly force the in scope set: ~4%
* nonDetCmpType: Try to short cut using reallyUnsafePtrEquality#: ~2%
* lintM: Use a unboxed maybe for the `a` result: ~12%
* lint_app: make go_app tail recursive to avoid allocating the go function
            as heap closure: ~7%
* expandSynTyCon_maybe: Use a specialized data type

For a less type heavy module like nofib/spectral/simple compiled with
-O -dcore-lint allocations went down by ~24% and compile time by ~9%.

-------------------------
Metric Decrease:
    T1969
-------------------------

9 files changed, 221 insertions, 59 deletions

diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs
index cab154aa5c..8a13ecb51b 100644
--- a/compiler/GHC/Core/Coercion.hs
+++ b/compiler/GHC/Core/Coercion.hs
@@ -781,7 +781,7 @@ mkTyConAppCo r tc cos
     mkFunCo r w co1 co2
 
                -- Expand type synonyms
-  | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos
+  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos
   = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos
 
   | Just tys_roles <- traverse isReflCo_maybe cos
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index d59376622f..844f753957 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -1370,7 +1370,7 @@ normaliseTcApp env role tc tys
 -- See Note [Normalising types] about the LiftingContext
 normalise_tc_app :: TyCon -> [Type] -> NormM Reduction
 normalise_tc_app tc tys
-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys
   , not (isFamFreeTyCon tc)  -- Expand and try again
   = -- A synonym with type families in the RHS
     -- Expand and try again
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index a9d01787fd..04f685de55 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -1,6 +1,8 @@
-{-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnboxedSums #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -95,6 +97,8 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith )
 import Data.List          ( partition )
 import Data.Maybe
 import GHC.Data.Pair
+import GHC.Base (oneShot)
+import GHC.Data.Unboxed
 
 {-
 Note [Core Lint guarantee]
@@ -263,6 +267,42 @@ case, however, we set le_joins to empty, and catch the
 error. Similarly, join points can occur free in RHSes of other join
 points but not the RHSes of value bindings (thunks and functions).
 
+Note [Avoiding compiler perf traps when constructing error messages.]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's quite common to put error messages into a where clause when it might
+be triggered by multiple branches. E.g.
+
+  checkThing x y z =
+    case x of
+      X -> unless (correctX x) $ failWithL errMsg
+      Y -> unless (correctY y) $ failWithL errMsg
+    where
+      errMsg = text "My error involving:" $$ ppr x <+> ppr y
+
+However ghc will compile this to:
+
+  checkThink x y z =
+    let errMsg = text "My error involving:" $$ ppr x <+> ppr y
+    in case x of
+      X -> unless (correctX x) $ failWithL errMsg
+      Y -> unless (correctY y) $ failWithL errMsg
+
+Putting the allocation of errMsg into the common non-error path.
+One way to work around this is to turn errMsg into a function:
+
+  checkThink x y z =
+    case x of
+      X -> unless (correctX x) $ failWithL (errMsg x y)
+      Y -> unless (correctY y) $ failWithL (errMsg x y)
+    where
+      errMsg x y = text "My error involving:" $$ ppr x <+> ppr y
+
+This way `errMsg` is a static function and it being defined in the common
+path does not result in allocation in the hot path. This can be surprisingly
+impactful. Changing `lint_app` reduced allocations for one test program I was
+looking at by ~4%.
+
+
 ************************************************************************
 *                                                                      *
                  Beginning and ending passes
@@ -1825,7 +1865,7 @@ lintTySynFamApp report_unsat ty tc tys
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
 
   -- Deal with type synonyms
-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys
   , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
   = do { -- Kind-check the argument types, but without reporting
          -- un-saturated type families/synonyms
@@ -1874,13 +1914,15 @@ lintArrow what t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw
 
 -----------------
 lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()
-lint_ty_app ty k tys
-  = lint_app (text "type" <+> quotes (ppr ty)) k tys
+lint_ty_app msg_ty k tys
+    -- See Note [Avoiding compiler perf traps when constructing error messages.]
+  = lint_app (\msg_ty -> text "type" <+> quotes (ppr msg_ty)) msg_ty k tys
 
 ----------------
 lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()
-lint_co_app ty k tys
-  = lint_app (text "coercion" <+> quotes (ppr ty)) k tys
+lint_co_app msg_ty k tys
+    -- See Note [Avoiding compiler perf traps when constructing error messages.]
+  = lint_app (\msg_ty -> text "coercion" <+> quotes (ppr msg_ty)) msg_ty k tys
 
 ----------------
 lintTyLit :: TyLit -> LintM ()
@@ -1891,46 +1933,62 @@ lintTyLit (NumTyLit n)
 lintTyLit (StrTyLit _) = return ()
 lintTyLit (CharTyLit _) = return ()
 
-lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()
+lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM ()
 -- (lint_app d fun_kind arg_tys)
 --    We have an application (f arg_ty1 .. arg_tyn),
 --    where f :: fun_kind
 
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-lint_app doc kfn arg_tys
-    = do { in_scope <- getInScope
+--
+-- Being strict in the kind here avoids quite a few pointless thunks
+-- reducing allocations by ~5%
+lint_app mk_msg msg_type !kfn arg_tys
+    = do { !in_scope <- getInScope
          -- We need the in_scope set to satisfy the invariant in
          -- Note [The substitution invariant] in GHC.Core.TyCo.Subst
-         ; _ <- foldlM (go_app in_scope) kfn arg_tys
-         ; return () }
+         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.
+         ; go_app in_scope kfn arg_tys
+         }
   where
-    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
-                          , nest 2 (text "Function kind =" <+> ppr kfn)
-                          , nest 2 (text "Arg types =" <+> ppr arg_tys)
-                          , extra ]
 
-    go_app in_scope kfn ta
+    -- We use explicit recursion instead of a fold here to avoid go_app becoming
+    -- an allocated function closure. This reduced allocations by up to 7% for some
+    -- modules.
+    go_app :: InScopeSet -> LintedKind -> [Type] -> LintM ()
+    go_app !in_scope !kfn ta
       | Just kfn' <- coreView kfn
       = go_app in_scope kfn' ta
 
-    go_app _ fun_kind@(FunTy _ _ kfa kfb) ta
+    go_app _in_scope _kind [] = return ()
+
+    go_app in_scope fun_kind@(FunTy _ _ kfa kfb) (ta:tas)
       = do { let ka = typeKind ta
            ; unless (ka `eqType` kfa) $
-             addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))
-           ; return kfb }
+             addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))
+           ; go_app in_scope kfb tas }
 
-    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta
+    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) (ta:tas)
       = do { let kv_kind = varType kv
                  ka      = typeKind ta
            ; unless (ka `eqType` kv_kind) $
-             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$
+             addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$
                                                     ppr ta <+> dcolon <+> ppr ka)))
-           ; return $ substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn }
+           ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn
+           ; go_app in_scope kind' tas }
 
     go_app _ kfn ta
-       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))
-
+       = failWithL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))
+
+-- This is a top level definition to ensure we pass all variables of the error message
+-- explicitly and don't capture them as free variables. Otherwise this binder might
+-- become a thunk that get's allocated in the hot code path.
+-- See Note [Avoiding compiler perf traps when constructing error messages.]
+lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc
+lint_app_fail_msg kfn arg_tys mk_msg msg_type extra = vcat [ hang (text "Kind application error in") 2 (mk_msg msg_type)
+                      , nest 2 (text "Function kind =" <+> ppr kfn)
+                      , nest 2 (text "Arg types =" <+> ppr arg_tys)
+                      , extra ]
 {- *********************************************************************
 *                                                                      *
         Linting rules
@@ -2672,14 +2730,41 @@ data StaticPtrCheck
   deriving Eq
 
 newtype LintM a =
-   LintM { unLintM ::
+   LintM' { unLintM ::
             LintEnv ->
             WarnsAndErrs ->           -- Warning and error messages so far
-            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
-   deriving (Functor)
+            LResult a } -- Result and messages (if any)
+
+
+pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+pattern LintM m <- LintM' m
+  where
+    LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we)
+    -- LintM m = LintM' (oneShot $ oneShot m)
+{-# COMPLETE LintM #-}
+
+instance Functor (LintM) where
+  fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w)
 
 type WarnsAndErrs = (Bag SDoc, Bag SDoc)
 
+-- Using a unboxed tuple here reduced allocations for a lint heavy
+-- file by ~6%. Using MaybeUB reduced them further by another ~12%.
+type LResult a = (# MaybeUB a, WarnsAndErrs #)
+
+pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a
+pattern LResult m w = (# m, w #)
+{-# COMPLETE LResult #-}
+
+mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2
+mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w
+
+-- Just for testing.
+fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a
+fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs
+fromBoxedLResult (Nothing,errs) = LResult NothingUB errs
+
 {- Note [Checking for global Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Before CoreTidy, all locally-bound Ids must be LocalIds, even
@@ -2804,21 +2889,27 @@ Wrinkle 2: 'hasNoBinding' and laziness
 -}
 
 instance Applicative LintM where
-      pure x = LintM $ \ _ errs -> (Just x, errs)
+      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs
+                                   --(Just x, errs)
       (<*>) = ap
 
 instance Monad LintM where
   m >>= k  = LintM (\ env errs ->
-                       let (res, errs') = unLintM m env errs in
+                       let res = unLintM m env errs in
                          case res of
-                           Just r -> unLintM (k r) env errs'
-                           Nothing -> (Nothing, errs'))
+                           LResult (JustUB r) errs' -> unLintM (k r) env errs'
+                           LResult NothingUB errs' -> LResult NothingUB errs'
+                    )
+                          --  LError errs'-> LError errs')
+                      --  let (res, errs') = unLintM m env errs in
+                          --  Just r -> unLintM (k r) env errs'
+                          --  Nothing -> (Nothing, errs'))
 
 instance MonadFail LintM where
     fail err = failWithL (text err)
 
 getPlatform :: LintM Platform
-getPlatform = LintM (\ e errs -> (Just (le_platform e), errs))
+getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs))
 
 data LintLocInfo
   = RhsOf Id            -- The variable bound
@@ -2851,9 +2942,9 @@ initL :: LintConfig
       -> WarnsAndErrs
 initL cfg m
   = case unLintM m env (emptyBag, emptyBag) of
-      (Just _, errs) -> errs
-      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs
-                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++
+      LResult (JustUB _) errs -> errs
+      LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs
+                                    | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++
                                                       "without reporting an error message") empty
   where
     (tcvs, ids) = partition isTyCoVar $ l_vars cfg
@@ -2882,7 +2973,7 @@ noFixedRuntimeRepChecks thing_inside
     in unLintM thing_inside env' errs
 
 getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
+getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)
 
 checkL :: Bool -> SDoc -> LintM ()
 checkL True  _   = return ()
@@ -2898,15 +2989,15 @@ checkWarnL False msg = addWarnL msg
 
 failWithL :: SDoc -> LintM a
 failWithL msg = LintM $ \ env (warns,errs) ->
-                (Nothing, (warns, addMsg True env errs msg))
+                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))
 
 addErrL :: SDoc -> LintM ()
 addErrL msg = LintM $ \ env (warns,errs) ->
-              (Just (), (warns, addMsg True env errs msg))
+              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))
 
 addWarnL :: SDoc -> LintM ()
 addWarnL msg = LintM $ \ env (warns,errs) ->
-              (Just (), (addMsg False env warns msg, errs))
+              fromBoxedLResult (Just (), (addMsg False env warns msg, errs))
 
 addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc
 addMsg is_error env msgs msg
@@ -2938,7 +3029,7 @@ addLoc extra_loc m
     unLintM m (env { le_loc = extra_loc : le_loc env }) errs
 
 inCasePat :: LintM Bool         -- A slight hack; see the unique call site
-inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
+inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs)
   where
     is_case_pat (LE { le_loc = CasePat {} : _ }) = True
     is_case_pat _other                           = False
@@ -2954,7 +3045,7 @@ addInScopeId id linted_ty m
       | otherwise   = delVarSet    join_set id -- Remove any existing binding
 
 getInScopeIds :: LintM (VarEnv (Id,LintedType))
-getInScopeIds = LintM (\env errs -> (Just (le_ids env), errs))
+getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs))
 
 extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendTvSubstL tv ty m
@@ -2974,16 +3065,16 @@ markAllJoinsBadIf True  m = markAllJoinsBad m
 markAllJoinsBadIf False m = m
 
 getValidJoins :: LintM IdSet
-getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))
+getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))
 
 getSubst :: LintM Subst
-getSubst = LintM (\ env errs -> (Just (le_subst env), errs))
+getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))
 
 getUEAliases :: LintM (NameEnv UsageEnv)
-getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs))
+getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))
 
 getInScope :: LintM InScopeSet
-getInScope = LintM (\ env errs -> (Just (getSubstInScope $ le_subst env), errs))
+getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs))
 
 lookupIdInScope :: Id -> LintM (Id, LintedType)
 lookupIdInScope id_occ
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 54672ab80d..5ae1e2bf6b 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -108,6 +108,7 @@ module GHC.Core.TyCon(
         mkTyConTagMap,
 
         -- ** Manipulating TyCons
+        ExpandSynResult(..),
         expandSynTyCon_maybe,
         newTyConCo, newTyConCo_maybe,
         pprPromotionQuote, mkTyConKind,
@@ -2521,12 +2522,14 @@ isConcreteTyConFlavour = \case
 -----------------------------------------------
 -}
 
+data ExpandSynResult tyco
+  = NoExpansion
+  | ExpandsSyn [(TyVar,tyco)] Type [tyco]
+
 expandSynTyCon_maybe
         :: TyCon
         -> [tyco]                 -- ^ Arguments to 'TyCon'
-        -> Maybe ([(TyVar,tyco)],
-                  Type,
-                  [tyco])         -- ^ Returns a 'TyVar' substitution, the body
+        -> ExpandSynResult tyco       -- ^ Returns a 'TyVar' substitution, the body
                                   -- type of the synonym (not yet substituted)
                                   -- and any arguments remaining from the
                                   -- application
@@ -2536,13 +2539,13 @@ expandSynTyCon_maybe
 expandSynTyCon_maybe tc tys
   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
   = if arity == 0
-    then Just ([], rhs, tys)  -- Avoid a bit of work in the case of nullary synonyms
+    then ExpandsSyn [] rhs tys  -- Avoid a bit of work in the case of nullary synonyms
     else case tys `listLengthCmp` arity of
-              GT -> Just (tvs `zip` tys, rhs, drop arity tys)
-              EQ -> Just (tvs `zip` tys, rhs, [])
-              LT -> Nothing
+              GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys)
+              EQ -> ExpandsSyn (tvs `zip` tys) rhs []
+              LT -> NoExpansion
    | otherwise
-   = Nothing
+   = NoExpansion
 
 ----------------
 
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 17519d8dd5..8d41466d30 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -4,6 +4,7 @@
 -- Type - public interface
 
 {-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE MagicHash #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -294,10 +295,10 @@ import GHC.Data.Pair
 import GHC.Data.List.SetOps
 import GHC.Types.Unique ( nonDetCmpUnique )
 
+import GHC.Base (reallyUnsafePtrEquality#)
 import GHC.Data.Maybe   ( orElse, expectJust, isJust )
 import Control.Monad    ( guard )
 import qualified Data.Semigroup as S
--- import GHC.Utils.Trace
 
 -- $type_classification
 -- #type_classification#
@@ -556,7 +557,7 @@ expandTypeSynonyms ty
     in_scope = mkInScopeSet (tyCoVarsOfType ty)
 
     go subst (TyConApp tc tys)
-      | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys
+      | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys
       = let subst' = mkTvSubst in_scope (mkVarEnv tenv)
             -- Make a fresh substitution; rhs has nothing to
             -- do with anything that has happened so far
@@ -2787,6 +2788,16 @@ comparing type variables is nondeterministic, note the call to nonDetCmpVar in
 nonDetCmpTypeX.
 See Note [Unique Determinism] for more details.
 
+Note [Type comparisons using object pointer comparisons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Quite often we substitute the type from a definition site into
+occurances without a change. This means for code like:
+    \x -> (x,x,x)
+The type of every `x` will often be represented by a single object
+in the heap. We can take advantage of this by shortcutting the equality
+check if two types are represented by the same pointer under the hood.
+In some cases this reduces compiler allocations by ~2%.
+
 Note [Computing equality on types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There are several places within GHC that depend on the precise choice of
@@ -2800,11 +2811,15 @@ See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.
 -}
 
 nonDetCmpType :: Type -> Type -> Ordering
+nonDetCmpType !t1 !t2
+  -- See Note [Type comparisons using object pointer comparisons]
+  | 1# <- reallyUnsafePtrEquality# t1 t2
+  = EQ
 nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2
   = EQ
-nonDetCmpType t1 t2
+nonDetCmpType t1 t2 =
   -- we know k1 and k2 have the same kind, because they both have kind *.
-  = nonDetCmpTypeX rn_env t1 t2
+  nonDetCmpTypeX rn_env t1 t2
   where
     rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))
 {-# INLINE nonDetCmpType #-}
diff --git a/compiler/GHC/Data/Unboxed.hs b/compiler/GHC/Data/Unboxed.hs
new file mode 100644
index 0000000000..dbd197351b
--- /dev/null
+++ b/compiler/GHC/Data/Unboxed.hs
@@ -0,0 +1,50 @@
+-- Unboxed counterparts to data structures
+
+{-# LANGUAGE UnboxedSums #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UnliftedNewtypes #-}
+
+module GHC.Data.Unboxed (
+  MaybeUB(JustUB, NothingUB),
+  fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB
+  ) where
+
+import GHC.Prelude hiding (Maybe(..), Either(..))
+
+-- | Like Maybe, but using unboxed sums.
+--
+-- Use with care. Using a unboxed maybe is not always a win
+-- in execution *time* even when allocations go down. So make
+-- sure to benchmark for execution time as well. If the difference
+-- in *runtime* for the compiler is too small to measure it's likely
+-- better to use a regular Maybe instead.
+--
+-- This is since it causes more function arguments to be passed, and
+-- potentially more variables to be captured by closures increasing
+-- closure size.
+newtype MaybeUB a = MaybeUB (# (# #) | a #)
+
+pattern JustUB :: a -> MaybeUB a
+pattern JustUB x = MaybeUB (# | x #)
+
+pattern NothingUB :: MaybeUB a
+pattern NothingUB = MaybeUB (# (# #) | #)
+
+{-# COMPLETE NothingUB, JustUB #-}
+
+fromMaybeUB :: a -> MaybeUB a -> a
+fromMaybeUB d NothingUB = d
+fromMaybeUB _ (JustUB x) = x
+
+apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b
+apMaybeUB (JustUB f) (JustUB x) = JustUB (f x)
+apMaybeUB _ _ = NothingUB
+
+fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b
+fmapMaybeUB _f NothingUB = NothingUB
+fmapMaybeUB f (JustUB x) = JustUB $ f x
+
+maybeUB :: b -> (a -> b) -> MaybeUB a -> b
+maybeUB _def f (JustUB x) = f x
+maybeUB def _f NothingUB = def
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0ac1080c65..8e71fcaf31 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -387,6 +387,7 @@ Library
         GHC.Data.Strict
         GHC.Data.StringBuffer
         GHC.Data.TrieMap
+        GHC.Data.Unboxed
         GHC.Data.UnionFind
         GHC.Driver.Backend
         GHC.Driver.Backend.Internal
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 423fd15533..3a6bae10fb 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -96,6 +96,7 @@ GHC.Data.Stream
 GHC.Data.Strict
 GHC.Data.StringBuffer
 GHC.Data.TrieMap
+GHC.Data.Unboxed
 GHC.Driver.Backend
 GHC.Driver.Backend.Internal
 GHC.Driver.CmdLine
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index b6e55ec846..df3f46f307 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -96,6 +96,7 @@ GHC.Data.Stream
 GHC.Data.Strict
 GHC.Data.StringBuffer
 GHC.Data.TrieMap
+GHC.Data.Unboxed
 GHC.Driver.Backend
 GHC.Driver.Backend.Internal
 GHC.Driver.Backpack.Syntax