StgLint: Enforce MultiValAlt liveness invariant only after unariser

The unariser ensures that we never use case binders that are void,
unboxed sums, or unboxed tuples. However, previously StgLint was
enforcing this invariant even before the unariser was running, giving
rise to spurious lint failures.  Fix this. Following CoreLint, we
introduce a LintFlags environment to the linter monad, allowing for
additional flags to be easily accomodated in the future.

See #14118.

Test Plan: Build GHC with -dstg-lint

Reviewers: simonpj, austin

Subscribers: rwbarton, thomie

GHC Trac Issues: #14118

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

1 files changed, 38 insertions, 22 deletions

diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index baceca2333..ac25ab5f50 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -56,11 +56,12 @@ generation.  Solution: don't use it!  (KSW 2000-05).
 @lintStgTopBindings@ is the top-level interface function.
 -}
 
-lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding]
+lintStgTopBindings :: Bool  -- ^ have we run Unarise yet?
+                   -> String -> [StgTopBinding] -> [StgTopBinding]
 
-lintStgTopBindings whodunnit binds
+lintStgTopBindings unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case (initL (lint_binds binds)) of
+    case (initL unarised (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (vcat [
                         text "*** Stg Lint ErrMsgs: in" <+>
@@ -196,11 +197,16 @@ 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
-        MultiValAlt _ -> return False -- Binder is always dead in this case
+        -- 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] $
@@ -275,12 +281,17 @@ lintAlt scrut_ty (DataAlt con, args, rhs) = do
 -}
 
 newtype LintM a = LintM
-    { unLintM :: [LintLocInfo]      -- Locations
+    { unLintM :: LintFlags
+              -> [LintLocInfo]      -- Locations
               -> IdSet              -- Local vars in scope
               -> Bag MsgDoc        -- Error messages so far
               -> (a, Bag MsgDoc)   -- Result and error messages (if any)
     }
 
+data LintFlags = LintFlags { lf_unarised :: !Bool
+                             -- ^ have we run the unariser yet?
+                           }
+
 data LintLocInfo
   = RhsOf Id            -- The variable bound
   | LambdaBodyOf [Id]   -- The lambda-binder
@@ -303,20 +314,22 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: LintM a -> Maybe MsgDoc
-initL (LintM m)
-  = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
+initL :: Bool -> LintM a -> Maybe MsgDoc
+initL unarised (LintM m)
+  = case (m lf [] emptyVarSet emptyBag) of { (_, errs) ->
     if isEmptyBag errs then
         Nothing
     else
         Just (vcat (punctuate blankLine (bagToList errs)))
     }
+  where
+    lf = LintFlags unarised
 
 instance Functor LintM where
       fmap = liftM
 
 instance Applicative LintM where
-      pure a = LintM $ \_loc _scope errs -> (a, errs)
+      pure a = LintM $ \_lf _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -325,21 +338,21 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \loc scope errs
-  -> case unLintM m loc scope errs of
-      (r, errs') -> unLintM (k r) loc scope errs'
+thenL m k = LintM $ \lf loc scope errs
+  -> case unLintM m lf loc scope errs of
+      (r, errs') -> unLintM (k r) lf loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \loc scope errs
-  -> case unLintM m loc scope errs of
-      (_, errs') -> unLintM k loc scope errs'
+thenL_ m k = LintM $ \lf loc scope errs
+  -> case unLintM m lf loc scope errs of
+      (_, errs') -> unLintM k lf loc scope errs'
 
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
 checkL False msg = addErrL msg
 
 addErrL :: MsgDoc -> LintM ()
-addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
 
 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
 addErr errs_so_far msg locs
@@ -350,14 +363,17 @@ addErr errs_so_far msg locs
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \loc scope errs
-   -> unLintM m (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \lf loc scope errs
+   -> unLintM m lf (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \loc scope errs
+addInScopeVars ids m = LintM $ \lf loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m loc (scope `unionVarSet` new_set) errs
+    in unLintM m lf loc (scope `unionVarSet` new_set) errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
 
 {-
 Checking function applications: we only check that the type has the
@@ -457,7 +473,7 @@ stgEqType orig_ty1 orig_ty2
                           -- Type variables in particular
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \loc scope errs
+checkInScope id = LintM $ \_lf loc scope errs
  -> if isLocalId id && not (id `elemVarSet` scope) then
         ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
                                 text "is out of scope"]) loc)
@@ -465,7 +481,7 @@ checkInScope id = LintM $ \loc scope errs
         ((), errs)
 
 checkTys :: Type -> Type -> MsgDoc -> LintM ()
-checkTys ty1 ty2 msg = LintM $ \loc _scope errs
+checkTys ty1 ty2 msg = LintM $ \_lf loc _scope errs
   -> if (ty1 `stgEqType` ty2)
      then ((), errs)
      else ((), addErr errs msg loc)