StgLint overhaul

- Remove all type checks
- Check two STG invariants (no unboxed let bindings, variables defined
  before used) and post-unarisation invariants.

See the module header and #14787.

This version validates with `-dstg-lint` added to `GhcStage2HcOpts` and
`GhcLibHcOpts` and `EXTRA_HC_OPTS`.

Unarise changes:

- `unariseConArgBinder` and `unariseFunArgBinder` functions were almost
  the same; only difference was when unarising fun args we keep void
  args while in con args we drop them. A new function `unariseArgBinder`
  added with a `Bool` argument for whether we're unarising a con arg.
  `unariseConArgBinder` and `unariseFunArgBinder` are now defined as

      unariseConArgBinder = unarsieArgBinder True  -- data con
      unariseFunArgBinder = unariseArgBinder False -- not data con

- A bug in `unariseConArgBinder` and `unariseFunArgBinder` (which are
  just calls to `unariseArgBinder` now) that invalidated the
  post-unarise invariants when the argument has single type rep (i.e.
  `length (typePrimRep x) == 1`) fixed. This isn't a correctness issue
  (it's fine not to unarise if a variable is already represented as
  single value), but it triggers StgLint.

Test Plan:
- Pass testsuite with `-dstg-lint` [done]
- Boot stage2 (including libraries) with `-dstg-lint` [done]

Reviewers: simonpj, bgamari

Reviewed By: bgamari

Subscribers: duog, rwbarton, thomie, carter

GHC Trac Issues: #14787

Differential Revision: https://phabricator.haskell.org/D4404

5 files changed, 196 insertions, 338 deletions

diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 6bdc1c9573..854bb92258 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -46,8 +46,9 @@ stg2stg dflags binds
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
                         (pprStgTopBindings processed_binds)
 
-        ; let un_binds = stg_linter True "Unarise"
-                         $ unarise us processed_binds
+        ; let un_binds = unarise us processed_binds
+
+        ; stg_linter True "Unarise" un_binds
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
                         (pprStgTopBindings un_binds)
@@ -57,8 +58,8 @@ stg2stg dflags binds
 
   where
     stg_linter unarised
-      | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised
-      | otherwise                    = \ _whodunnit binds -> binds
+      | gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
+      | otherwise                    = \ _whodunnit _binds -> return ()
 
     -------------------------------------------
     do_stg_pass binds to_do
@@ -78,7 +79,8 @@ stg2stg dflags binds
       = do -- report verbosely, if required
            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
               (vcat (map ppr binds2))
-           return (stg_linter False what binds2)
+           stg_linter False what binds2
+           return binds2
 
 -- -----------------------------------------------------------------------------
 -- StgToDo:  abstraction of stg-to-stg passes to run.
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index 6fb8d0ea2d..57dd699f70 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -203,7 +203,7 @@ import CoreSyn
 import DataCon
 import FastString (FastString, mkFastString)
 import Id
-import Literal (Literal (..))
+import Literal (Literal (..), literalType)
 import MkCore (aBSENT_ERROR_ID)
 import MkId (voidPrimId, voidArgId)
 import MonadUtils (mapAccumLM)
@@ -334,7 +334,7 @@ unariseExpr _ e@StgLam{}
   = pprPanic "unariseExpr: found lambda" (ppr e)
 
 unariseExpr rho (StgCase scrut bndr alt_ty alts)
-  -- a tuple/sum binders in the scrutinee can always be eliminated
+  -- tuple/sum binders in the scrutinee can always be eliminated
   | StgApp v [] <- scrut
   , Just (MultiVal xs) <- lookupVarEnv rho v
   = elimCase rho xs bndr alt_ty alts
@@ -351,7 +351,8 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
   = do scrut' <- unariseExpr rho scrut
        alts'  <- unariseAlts rho alt_ty bndr alts
        return (StgCase scrut' bndr alt_ty alts')
-                       -- bndr will be dead after unarise
+                       -- bndr may have a unboxed sum/tuple type but it will be
+                       -- dead after unarise (checked in StgLint)
 
 unariseExpr rho (StgLet bind e)
   = StgLet <$> unariseBinding rho bind <*> unariseExpr rho e
@@ -642,6 +643,35 @@ So in short, when we have a void id,
                          in argument position of a DataCon application.
 -}
 
+unariseArgBinder
+    :: Bool -- data con arg?
+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseArgBinder is_con_arg rho x =
+  case typePrimRep (idType x) of
+    []
+      | is_con_arg
+      -> return (extendRho rho x (MultiVal []), [])
+      | otherwise -- fun arg, do not remove void binders
+      -> return (extendRho rho x (MultiVal []), [voidArgId])
+
+    [rep]
+      -- Arg represented as single variable, but original type may still be an
+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
+      --
+      -- While not unarising the binder in this case does not break any programs
+      -- (because it unarises to a single variable), it triggers StgLint as we
+      -- break the the post-unarisation invariant that says unboxed tuple/sum
+      -- binders should vanish. See Note [Post-unarisation invariants].
+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
+      | otherwise
+      -> return (rho, [x])
+
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
 --------------------------------------------------------------------------------
 
 -- | MultiVal a function argument. Never returns an empty list.
@@ -660,16 +690,9 @@ unariseFunArgs = concatMap . unariseFunArg
 unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
 unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
 
-unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
 -- Result list of binders is never empty
-unariseFunArgBinder rho x  =
-  case typePrimRep (idType x) of
-    []   -> return (extendRho rho x (MultiVal []), [voidArgId])
-                           -- NB: do not remove void binders
-    [_]  -> return (rho, [x])
-    reps -> do
-      xs <- mkIds (mkFastString "us") (map primRepToType reps)
-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
 
 --------------------------------------------------------------------------------
 
@@ -684,7 +707,9 @@ unariseConArg rho (StgVarArg x) =
                                   -- Here realWorld# is not in the envt, but
                                   -- is a void, and so should be eliminated
       | otherwise -> [StgVarArg x]
-unariseConArg _ arg = [arg]       -- We have no void literals
+unariseConArg _ arg@(StgLitArg lit) =
+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
+    [arg]
 
 unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
 unariseConArgs = concatMap . unariseConArg
@@ -692,13 +717,10 @@ unariseConArgs = concatMap . unariseConArg
 unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
 unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
 
+-- Different from `unariseFunArgBinder`: result list of binders may be empty.
+-- See DataCon applications case in Note [Post-unarisation invariants].
 unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-unariseConArgBinder rho x =
-  case typePrimRep (idType x) of
-    [_]  -> return (rho, [x])
-    reps -> do
-      xs <- mkIds (mkFastString "us") (map primRepToType reps)
-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+unariseConArgBinder = unariseArgBinder True
 
 unariseFreeVars :: UnariseEnv -> [InId] -> [OutId]
 unariseFreeVars rho fvs
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 70231f2863..bb2064ab48 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -1,10 +1,36 @@
-{-
+{- |
 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 
-\section[StgLint]{A ``lint'' pass to check for Stg correctness}
--}
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+  appear in case), except when they're join points (see Note [CoreSyn let/app
+  invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+  invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
 
-{-# LANGUAGE CPP #-}
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+    WARNING:
+    ~~~~~~~~
+
+    This module has suffered bit-rot; it is likely to yield lint errors
+    for Stg code that is currently perfectly acceptable for code
+    generation.  Solution: don't use it!  (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
 
 module StgLint ( lintStgTopBindings ) where
 
@@ -12,66 +38,43 @@ import GhcPrelude
 
 import StgSyn
 
+import DynFlags
 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 import Id               ( Id, idType, isLocalId, isJoinId )
 import VarSet
 import DataCon
 import CoreSyn          ( AltCon(..) )
-import PrimOp           ( primOpType )
-import Literal          ( literalType )
-import Maybes
 import Name             ( getSrcLoc )
 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
 import Type
 import RepType
-import TyCon
-import Util
 import SrcLoc
 import Outputable
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
 import Control.Monad
 
-#include "HsVersions.h"
-
-{-
-Checks for
-        (a) *some* type errors
-        (b) locally-defined variables used but not defined
-
-
-Note: unless -dverbose-stg is on, display of lint errors will result
-in "panic: bOGUS_LVs".
-
-WARNING:
-~~~~~~~~
-
-This module has suffered bit-rot; it is likely to yield lint errors
-for Stg code that is currently perfectly acceptable for code
-generation.  Solution: don't use it!  (KSW 2000-05).
-
-
-************************************************************************
-*                                                                      *
-\subsection{``lint'' for various constructs}
-*                                                                      *
-************************************************************************
-
-@lintStgTopBindings@ is the top-level interface function.
--}
-
-lintStgTopBindings :: Bool  -- ^ have we run Unarise yet?
-                   -> String -> [StgTopBinding] -> [StgTopBinding]
+lintStgTopBindings :: DynFlags
+                   -> Bool   -- ^ have we run Unarise yet?
+                   -> String -- ^ who produced the STG?
+                   -> [StgTopBinding]
+                   -> IO ()
 
-lintStgTopBindings unarised whodunnit binds
+lintStgTopBindings dflags unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case (initL unarised (lint_binds binds)) of
-      Nothing  -> binds
-      Just msg -> pprPanic "" (vcat [
-                        text "*** Stg Lint ErrMsgs: in" <+>
-                              text whodunnit <+> text "***",
-                        msg,
-                        text "*** Offending Program ***",
-                        pprStgTopBindings binds,
-                        text "*** End of Offense ***"])
+    case initL unarised (lint_binds binds) of
+      Nothing  ->
+        return ()
+      Just msg -> do
+        putLogMsg dflags NoReason Err.SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+                        text whodunnit <+> text "***",
+                  msg,
+                  text "*** Offending Program ***",
+                  pprStgTopBindings binds,
+                  text "*** End of Offense ***"])
+        Err.ghcExit dflags 1
   where
     lint_binds :: [StgTopBinding] -> LintM ()
 
@@ -84,13 +87,12 @@ lintStgTopBindings unarised whodunnit binds
     lint_bind (StgTopLifted bind) = lintStgBinds bind
     lint_bind (StgTopStringLit v _) = return [v]
 
-lintStgArg :: StgArg -> LintM (Maybe Type)
-lintStgArg (StgLitArg lit) = return (Just (literalType lit))
-lintStgArg (StgVarArg v)   = lintStgVar v
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
 
-lintStgVar :: Id -> LintM (Maybe Kind)
-lintStgVar v = do checkInScope v
-                  return (Just (idType v))
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
 
 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
 lintStgBinds (StgNonRec binder rhs) = do
@@ -107,80 +109,50 @@ lintStgBinds (StgRec pairs)
 lint_binds_help :: (Id, StgRhs) -> LintM ()
 lint_binds_help (binder, rhs)
   = addLoc (RhsOf binder) $ do
-        -- Check the rhs
-        _maybe_rhs_ty <- lintStgRhs rhs
-
-        -- Check binder doesn't have unlifted type
-        checkL (isJoinId binder || not (isUnliftedType binder_ty))
+        lintStgRhs rhs
+        -- Check binder doesn't have unlifted type or it's a join point
+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
                (mkUnliftedTyMsg binder rhs)
 
-        -- Check match to RHS type
-        -- Actually we *can't* check the RHS type, because
-        -- unsafeCoerce means it really might not match at all
-        -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...
-        -- case maybe_rhs_ty of
-        --  Nothing     -> return ()
-        --    Just rhs_ty -> checkTys binder_ty
-        --                          rhs_ty
-        ---                         (mkRhsMsg binder rhs_ty)
-
-        return ()
-  where
-    binder_ty = idType binder
-
-lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
+lintStgRhs :: StgRhs -> LintM ()
 
 lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
   = lintStgExpr expr
 
 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) $
-      addInScopeVars binders $ runMaybeT $ do
-        body_ty <- MaybeT $ lintStgExpr expr
-        return (mkFunTys (map idType binders) body_ty)
+      addInScopeVars binders $
+        lintStgExpr expr
 
 lintStgRhs rhs@(StgRhsCon _ con args) = do
-    -- TODO: Check arg_tys
     when (isUnboxedTupleCon con || isUnboxedSumCon con) $
       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
                ppr rhs)
-    runMaybeT $ do
-      arg_tys <- mapM (MaybeT . lintStgArg) args
-      MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
-  where
-    con_ty = dataConRepType con
-
-lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
 
-lintStgExpr (StgLit l) = return (Just (literalType l))
+lintStgExpr :: StgExpr -> LintM ()
 
-lintStgExpr e@(StgApp fun args) = runMaybeT $ do
-    fun_ty <- MaybeT $ lintStgVar fun
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
+lintStgExpr (StgLit _) = return ()
 
-lintStgExpr e@(StgConApp con args _arg_tys) = runMaybeT $ do
-    -- TODO: Check arg_tys
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
-  where
-    con_ty = dataConRepType con
+lintStgExpr (StgApp fun args) = do
+    lintStgVar fun
+    mapM_ lintStgArg args
 
-lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
-    arg_tys <- mapM (MaybeT . lintStgArg) args
-    MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
-  where
-    op_ty = primOpType op
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+    -- unboxed sums should vanish during unarise
+    lf <- getLintFlags
+    when (lf_unarised lf && isUnboxedSumCon con) $
+      addErrL (text "Unboxed sum after unarise:" $$
+               ppr app)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
 
-lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do
-        -- We don't have enough type information to check
-        -- the application for StgFCallOp and StgPrimCallOp; ToDo
-    _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
-    return res_ty
+lintStgExpr (StgOpApp _ args _) =
+    mapM_ lintStgArg args
 
-lintStgExpr (StgLam bndrs _) = do
-    addErrL (text "Unexpected StgLam" <+> ppr bndrs)
-    return Nothing
+lintStgExpr lam@(StgLam _ _) =
+    addErrL (text "Unexpected StgLam" <+> ppr lam)
 
 lintStgExpr (StgLet binds body) = do
     binders <- lintStgBinds binds
@@ -196,83 +168,33 @@ lintStgExpr (StgLetNoEscape binds body) = do
 
 lintStgExpr (StgTick _ expr) = lintStgExpr expr
 
-lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
-    _ <- MaybeT $ lintStgExpr scrut
-
-    lf <- liftMaybeT getLintFlags
-    in_scope <- MaybeT $ liftM Just $
-     case alts_type of
-        AlgAlt tc     -> check_bndr (tyConPrimRep tc) >> return True
-        PrimAlt rep   -> check_bndr [rep]             >> return True
-        -- Case binders of unboxed tuple or unboxed sum type always dead
-        -- after the unariser has run. See Note [Post-unarisation invariants].
-        MultiValAlt _
-          | lf_unarised lf -> return False
-          | otherwise      -> return True
-        PolyAlt       -> return True
-
-    MaybeT $ addInScopeVars [bndr | in_scope] $
-             lintStgAlts alts scrut_ty
-  where
-    scrut_ty        = idType bndr
-    scrut_reps      = typePrimRep scrut_ty
-    check_bndr reps = checkL (scrut_reps == reps) bad_bndr
-                  where
-                     bad_bndr = mkDefltMsg bndr reps
-
-lintStgAlts :: [StgAlt]
-            -> Type               -- Type of scrutinee
-            -> LintM (Maybe Type) -- Just ty => type is accurage
-
-lintStgAlts alts scrut_ty = do
-    maybe_result_tys <- mapM (lintAlt scrut_ty) alts
-
-    -- Check the result types
-    case catMaybes (maybe_result_tys) of
-      []             -> return Nothing
-
-      (first_ty:_tys) -> do -- mapM_ check tys
-                           return (Just first_ty)
-        where
-          -- check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-          -- We can't check that the alternatives have the
-          -- same type, because they don't, with unsafeCoerce#
-
-lintAlt :: Type -> (AltCon, [Id], StgExpr) -> LintM (Maybe Type)
-lintAlt _ (DEFAULT, _, rhs)
- = lintStgExpr rhs
-
-lintAlt scrut_ty (LitAlt lit, _, rhs) = do
-   checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
-   lintStgExpr rhs
-
-lintAlt scrut_ty (DataAlt con, args, rhs) = do
-    case splitTyConApp_maybe scrut_ty of
-      Just (tycon, tys_applied) | isAlgTyCon tycon &&
-                                  not (isNewTyCon tycon) -> do
-         let
-           cons    = tyConDataCons tycon
-           arg_tys = dataConInstArgTys con tys_applied
-                -- This does not work for existential constructors
-
-         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
-         checkL (args `lengthIs` dataConRepArity con) (mkAlgAltMsg3 con args)
-         when (isVanillaDataCon con) $
-           mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
-         return ()
-      _ ->
-         addErrL (mkAltMsg1 scrut_ty)
-
-    addInScopeVars args $
-         lintStgExpr rhs
-  where
-    check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+    lintStgExpr scrut
 
-    -- elem: yes, the elem-list here can sometimes be long-ish,
-    -- but as it's use-once, probably not worth doing anything different
-    -- We give it its own copy, so it isn't overloaded.
-    elem _ []       = False
-    elem x (y:ys)   = x==y || elem x ys
+    lf <- getLintFlags
+    let in_scope =
+          case alts_type of
+             AlgAlt _      -> True
+             PrimAlt _     -> True
+             -- Case binders of unboxed tuple or unboxed sum type always dead
+             -- after the unariser has run.
+             -- See Note [Post-unarisation invariants].
+             MultiValAlt _ -> not (lf_unarised lf)
+             PolyAlt       -> True
+
+    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (LitAlt _, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+    mapM_ checkPostUnariseBndr bndrs
+    addInScopeVars bndrs (lintStgExpr rhs)
 
 {-
 ************************************************************************
@@ -353,6 +275,44 @@ checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
 checkL False msg = addErrL msg
 
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+    lf <- getLintFlags
+    when (lf_unarised lf) $
+      forM_ (checkPostUnariseId bndr) $ \unexpected ->
+        addErrL $
+          text "After unarisation, binder " <>
+          ppr bndr <> text " has " <> text unexpected <> text " type " <>
+          ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+    StgLitArg _ ->
+      return ()
+    StgVarArg id -> do
+      lf <- getLintFlags
+      when (lf_unarised lf) $
+        forM_ (checkPostUnariseId id) $ \unexpected ->
+          addErrL $
+            text "After unarisation, arg " <>
+            ppr id <> text " has " <> text unexpected <> text " type " <>
+            ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+    let
+      id_ty = idType id
+      is_sum, is_tuple, is_void :: Maybe String
+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+      is_void = guard (isVoidTy id_ty) >> return "void"
+    in
+      is_sum <|> is_tuple <|> is_void
+
 addErrL :: MsgDoc -> LintM ()
 addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
 
@@ -377,67 +337,6 @@ addInScopeVars ids m = LintM $ \lf loc scope errs
 getLintFlags :: LintM LintFlags
 getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
 
-{-
-Checking function applications: we only check that the type has the
-right *number* of arrows, we don't actually compare the types.  This
-is because we can't expect the types to be equal - the type
-applications and type lambdas that we use to calculate accurate types
-have long since disappeared.
--}
-
-checkFunApp :: Type                 -- The function type
-            -> [Type]               -- The arg type(s)
-            -> MsgDoc               -- Error message
-            -> LintM (Maybe Type)   -- Just ty => result type is accurate
-
-checkFunApp fun_ty arg_tys msg
- = do { case mb_msg of
-          Just msg -> addErrL msg
-          Nothing  -> return ()
-      ; return mb_ty }
- where
-  (mb_ty, mb_msg) = cfa True fun_ty arg_tys
-
-  cfa :: Bool -> Type -> [Type] -> (Maybe Type          -- Accurate result?
-                                   , Maybe MsgDoc)      -- Errors?
-
-  cfa accurate fun_ty []      -- Args have run out; that's fine
-      = (if accurate then Just fun_ty else Nothing, Nothing)
-
-  cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
-      | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-      = if accurate && not (arg_ty `stgEqType` arg_ty')
-        then (Nothing, Just msg)       -- Arg type mismatch
-        else cfa accurate res_ty arg_tys'
-
-      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
-      = cfa False fun_ty' arg_tys
-
-      | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
-      , isNewTyCon tc
-      = if tc_args `lengthLessThan` tyConArity tc
-        then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
-             (Nothing, Nothing)   -- This is odd, but I've seen it
-        else cfa False (newTyConInstRhs tc tc_args) arg_tys
-
-      | Just tc <- tyConAppTyCon_maybe fun_ty
-      , not (isTypeFamilyTyCon tc)      -- Definite error
-      = (Nothing, Just msg)             -- Too many args
-
-      | otherwise
-      = (Nothing, Nothing)
-
--- | "Compare" types. We used to try a crude comparison of the type themselves,
--- but this is essentially impossible in STG as we have discarded both casts
--- and type applications, so types might look different but be the same. Now we
--- simply compare their runtime representations. See #14120.
-stgEqType :: Type -> Type -> Bool
-stgEqType ty1 ty2
-  = reps1 == reps2
-  where
-    reps1 = typePrimRep ty1
-    reps2 = typePrimRep ty2
-
 checkInScope :: Id -> LintM ()
 checkInScope id = LintM $ \_lf loc scope errs
  -> if isLocalId id && not (id `elemVarSet` scope) then
@@ -446,72 +345,6 @@ checkInScope id = LintM $ \_lf loc scope errs
     else
         ((), errs)
 
-checkTys :: Type -> Type -> MsgDoc -> LintM ()
-checkTys ty1 ty2 msg = LintM $ \_lf loc _scope errs
-  -> if (ty1 `stgEqType` ty2)
-     then ((), errs)
-     else ((), addErr errs msg loc)
-
-_mkCaseAltMsg :: [StgAlt] -> MsgDoc
-_mkCaseAltMsg _alts
-  = ($$) (text "In some case alternatives, type of alternatives not all same:")
-            (Outputable.empty) -- LATER: ppr alts
-
-mkDefltMsg :: Id -> [PrimRep] -> MsgDoc
-mkDefltMsg bndr reps
-  = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")
-         (ppr bndr $$ ppr (idType bndr) $$ ppr reps)
-
-mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
-mkFunAppMsg fun_ty arg_tys expr
-  = vcat [text "In a function application, function type doesn't match arg types:",
-              hang (text "Function type:") 4 (ppr fun_ty),
-              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)),
-              hang (text "Expression:") 4 (ppr expr)]
-
-mkRhsConMsg :: Type -> [Type] -> MsgDoc
-mkRhsConMsg fun_ty arg_tys
-  = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
-              hang (text "Constructor type:") 4 (ppr fun_ty),
-              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))]
-
-mkAltMsg1 :: Type -> MsgDoc
-mkAltMsg1 ty
-  = ($$) (text "In a case expression, type of scrutinee does not match patterns")
-         (ppr ty)
-
-mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc
-mkAlgAltMsg2 ty con
-  = vcat [
-        text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
-        ppr ty,
-        ppr con
-    ]
-
-mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc
-mkAlgAltMsg3 con alts
-  = vcat [
-        text "In some algebraic case alternative, number of arguments doesn't match constructor:",
-        ppr con <+> parens (text "arity" <+> ppr (dataConRepArity con)),
-        ppr alts
-    ]
-
-mkAlgAltMsg4 :: Type -> Id -> MsgDoc
-mkAlgAltMsg4 ty arg
-  = vcat [
-        text "In some algebraic case alternative, type of argument doesn't match data constructor:",
-        ppr ty,
-        ppr arg
-    ]
-
-_mkRhsMsg :: Id -> Type -> MsgDoc
-_mkRhsMsg binder ty
-  = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:",
-                     ppr binder],
-              hsep [text "Binder's type:", ppr (idType binder)],
-              hsep [text "Rhs type:", ppr ty]
-             ]
-
 mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
 mkUnliftedTyMsg binder rhs
   = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 330e2b409f..29d544103f 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -549,6 +549,7 @@ data AltType
   = PolyAlt             -- Polymorphic (a lifted type variable)
   | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
                         -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
   | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
   | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
 
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index 48222ae467..cf926348a0 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -715,7 +715,7 @@ Checking for consistency
     :shortdesc: STG pass sanity checking
     :type: dynamic
 
-    Ditto for STG level. (note: currently doesn't work).
+    Ditto for STG level.
 
 .. ghc-flag:: -dcmm-lint
     :shortdesc: C-\\- pass sanity checking