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

2 files changed, 48 insertions, 24 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