TagAnalysis: Treat all bottom ids as tagged during analysis.

Ticket #24806 showed that we also need to treat dead end thunks as
tagged during the analysis.

compiler/GHC/Stg/InferTags.hs

@@ -16,6 +16,7 @@ import GHC.Types.Id.Info (tagSigInfo)
 import GHC.Types.Name
 import GHC.Stg.Syntax
 import GHC.Types.Basic ( CbvMark (..) )
+import GHC.Types.Demand (isDeadEndAppSig)
 import GHC.Types.Unique.Supply (mkSplitUniqSupply)
 import GHC.Types.RepType (dataConRuntimeRepStrictness)
 import GHC.Core (AltCon(..))
@@ -301,12 +302,14 @@ inferTagExpr env (StgApp fun args)
     (info, StgApp fun args)
   where
     !fun_arity = idArity fun
-    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call
-         = TagDunno
+    info
+         -- It's important that we check for bottoms before all else.
+         -- See Note [Bottom functions are TagTagged] and #24806 for why.
+         | isDeadEndAppSig (idDmdSig fun) (length args)
+         = TagTagged
 
-         | isDeadEndId fun
-         , fun_arity == length args -- Implies we will simply call the function.
-         = TagTagged -- See Note [Bottom functions are TagTagged]
+         | fun_arity == 0 -- Unknown arity => Thunk or unknown call
+         = TagDunno
 
          | Just (TagSig res_info) <- tagSigInfo (idInfo fun)
          , fun_arity == length args  -- Saturated
@@ -500,6 +503,11 @@ it safely any tag sig we like.
 So we give it TagTagged, as it allows the combined tag sig of the case expression
 to be the combination of all non-bottoming branches.
 
+NB: After the analysis is done we go back to treating bottoming functions as
+untagged to ensure they are evaluated as expected in code like:
+
+  case bottom_id of { ...}
+
 -}
 
 -----------------------------

compiler/GHC/Stg/InferTags/Rewrite.hs

@@ -241,7 +241,10 @@ indicates a bug in the tag inference implementation.
 For this reason we assert that we are running in interactive mode if a lookup fails.
 -}
 isTagged :: Id -> RM Bool
-isTagged v = do
+isTagged v
+    -- See Note [Bottom functions are TagTagged]
+    | isDeadEndId v = pure False
+    | otherwise = do
     this_mod <- getMod
     -- See Note [Tag inference for interactive contexts]
     let lookupDefault v = assertPpr (isInteractiveModule this_mod)

testsuite/tests/simplStg/should_compile/T24806.hs

+module T24806 ( go ) where
+
+data List a = Nil | Cons a !(List a) -- deriving Show
+
+data Tup2 a b = Tup2 !a !b
+
+-- All branches of go return either two properly tagged values *or* are bottom.
+-- This means we should see something like:
+--
+--      (T24806.$wgo, <TagTuple[TagProper, TagProper]>) =
+--
+-- in the dump output.
+-- See Note [Bottom functions are TagTagged] for details why.
+go :: List a1 -> List a2 -> Tup2 (List a2) (List a2)
+go Nil ys = Tup2 ys Nil
+go (Cons _ xs) ys = case ys of
+    Nil -> undefined
+    Cons y ys' -> case go xs ys' of
+        Tup2 s zs -> Tup2 s (Cons y zs)
\ No newline at end of file

testsuite/tests/simplStg/should_compile/T24806.stderr

+
+==================== CodeGenAnal STG: ====================
+lvl6 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+    "T24806.hs"#;
+
+lvl4 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+    "T24806"#;
+
+lvl2 :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+    "main"#;
+
+lvl :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []] =
+    "undefined"#;
+
+(T24806.$WTup2, <TagProper>) =
+    {} \r [(conrep, <TagDunno>) (conrep1, <TagDunno>)]
+        case conrep of (conrep2, <TagProper>) {
+        __DEFAULT ->
+        case conrep1 of (conrep3, <TagProper>) {
+        __DEFAULT -> T24806.Tup2 [conrep2 conrep3];
+        };
+        };
+
+(T24806.$WCons, <TagProper>) =
+    {} \r [(conrep, <TagDunno>) (conrep1, <TagDunno>)]
+        case conrep1 of (conrep2, <TagProper>) {
+        __DEFAULT -> T24806.Cons [conrep conrep2];
+        };
+
+(lvl1, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl;
+
+(lvl3, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl2;
+
+(lvl5, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl4;
+
+(lvl7, <TagDunno>) = {} \u [] GHC.CString.unpackCString# lvl6;
+
+(lvl8, <TagProper>) = GHC.Types.I#! [17#];
+
+(lvl9, <TagProper>) = GHC.Types.I#! [12#];
+
+(lvl10, <TagProper>) = GHC.Types.I#! [21#];
+
+(lvl11, <TagProper>) =
+    GHC.Internal.Stack.Types.SrcLoc! [lvl3
+                                      lvl5
+                                      lvl7
+                                      lvl8
+                                      lvl9
+                                      lvl8
+                                      lvl10];
+
+(lvl12, <TagProper>) =
+    GHC.Internal.Stack.Types.PushCallStack! [lvl1
+                                             lvl11
+                                             GHC.Internal.Stack.Types.EmptyCallStack];
+
+(lvl13, <TagDunno>) = {} \u [] GHC.Internal.Err.undefined lvl12;
+
+(T24806.Tup2, <TagDunno>) =
+    {} \r [(eta, <TagDunno>) (eta, <TagDunno>)] T24806.Tup2 [eta eta];
+
+(T24806.Nil, <TagProper>) = T24806.Nil! [];
+
+Rec {
+(T24806.$wgo, <TagTuple[TagProper, TagProper]>) =
+    {} \r [(ds, <TagProper>) (ys, <TagProper>)]
+        case ds of (wild, <TagProper>) {
+          T24806.Nil ->
+              case ys of (conrep, <TagProper>) {
+              __DEFAULT -> (#,#) [conrep T24806.Nil];
+              };
+          T24806.Cons (ds1, <TagDunno>) (xs, <TagProper>) ->
+              case ys of (wild1, <TagProper>) {
+                T24806.Nil -> lvl13;
+                T24806.Cons (y, <TagDunno>) (ys', <TagProper>) ->
+                    case T24806.$wgo xs ys' of (wild2, <TagProper>) {
+                    (#,#) (ww, <TagProper>) (ww1, <TagProper>) ->
+                    let { (sat, <TagProper>) = T24806.Cons! [y ww1];
+                    } in  (#,#) [ww sat];
+                    };
+              };
+        };
+end Rec }
+
+(T24806.go, <TagProper>) =
+    {} \r [(ds, <TagDunno>) (ys, <TagDunno>)]
+        case T24806.$wgo ds ys of (wild, <TagProper>) {
+        (#,#) (ww, <TagProper>) (ww1, <TagProper>) -> T24806.Tup2 [ww ww1];
+        };
+
+(T24806.Cons, <TagDunno>) =
+    {} \r [(eta, <TagDunno>) (eta, <TagDunno>)] T24806.Cons [eta eta];
+
+

testsuite/tests/simplStg/should_compile/all.T

@@ -23,3 +23,5 @@ test('inferTags003', [ only_ways(['optasm']),
                        grep_errmsg(r'(call stg\_ap\_0)', [1])
                      ], compile, ['-ddump-cmm -dno-typeable-binds -O'])
 test('inferTags004', normal, compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques'])
+
+test('T24806', grep_errmsg('^\\(T24806\\.\\$wgo'), compile, ['-O -ddump-stg-tags -dno-typeable-binds -dsuppress-uniques'])