Don't use isUnliftedType in isTagged

The function GHC.Stg.InferTags.Rewrite.isTagged can be given
the Id of a join point, which might be representation polymorphic.
This would cause the call to isUnliftedType to crash. It's better
to use typeLevity_maybe instead.

Fixes #22212

3 files changed, 57 insertions, 5 deletions

diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
index d2d0bbeb2f..99caa79ddb 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ b/compiler/GHC/Stg/InferTags/Rewrite.hs
@@ -21,15 +21,19 @@ where
 import GHC.Prelude
 
 import GHC.Builtin.PrimOps ( PrimOp(..) )
+import GHC.Types.Basic     ( CbvMark (..), isMarkedCbv
+                           , TopLevelFlag(..), isTopLevel
+                           , Levity(..) )
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique.FM
 import GHC.Types.RepType
-import GHC.Unit.Types (Module)
+import GHC.Types.Var.Set
+import GHC.Unit.Types      ( Module )
 
 import GHC.Core.DataCon
-import GHC.Core (AltCon(..) )
+import GHC.Core            ( AltCon(..) )
 import GHC.Core.Type
 
 import GHC.StgToCmm.Types
@@ -47,8 +51,7 @@ import GHC.Utils.Misc
 import GHC.Stg.InferTags.Types
 
 import Control.Monad
-import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel)
-import GHC.Types.Var.Set
+
 -- import GHC.Utils.Trace
 -- import GHC.Driver.Ppr
 
@@ -217,7 +220,9 @@ isTagged v = do
     this_mod <- getMod
     case nameIsLocalOrFrom this_mod (idName v) of
         True
-            | isUnliftedType (idType v)
+            | Just Unlifted <- typeLevity_maybe (idType v)
+              -- NB: v might be the Id of a representation-polymorphic join point,
+              -- so we shouldn't use isUnliftedType here. See T22212.
             -> return True
             | otherwise -> do -- Local binding
                 !s <- getMap
diff --git a/testsuite/tests/simplStg/should_compile/T22212.hs b/testsuite/tests/simplStg/should_compile/T22212.hs
new file mode 100644
index 0000000000..8a6e6c7da3
--- /dev/null
+++ b/testsuite/tests/simplStg/should_compile/T22212.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module T22212 where
+
+import GHC.Exts
+
+isNullAddr# :: Addr# -> (##)
+isNullAddr# a =
+  case eqAddr# a nullAddr# of
+    1# -> (##)
+    _  -> compareBytes (##)
+{-# INLINE isNullAddr# #-}
+
+compareBytes :: (##) -> (##)
+compareBytes _ = (##)
+{-# NOINLINE compareBytes #-}
+
+mArray :: forall {rep :: RuntimeRep} {res :: TYPE rep}
+       .  (  () -> () -> () -> () -> ()
+          -> () -> () -> () -> () -> ()
+          -> () -> () -> () -> () -> ()
+          -> () -> () -> () -> () -> ()
+          -> () -> () -> () -> () -> ()
+          -> res )
+       -> res
+mArray cont =
+  case isNullAddr# nullAddr# of
+    (##) ->
+      cont
+        () () () () ()
+        () () () () ()
+        () () () () ()
+        () () () () ()
+        () () () () ()
+          -- As of writing this test,
+          -- 9 arguments were required to trigger the bug.
+
+{-
+Original reproducer:
+
+data Sort = MkSort BS.ByteString [()]
+
+pattern Array :: () -> () -> Sort
+pattern Array x y = MkSort "Array" [x,y]
+-}
\ No newline at end of file
diff --git a/testsuite/tests/simplStg/should_compile/all.T b/testsuite/tests/simplStg/should_compile/all.T
index c5f9162579..4ad68258fa 100644
--- a/testsuite/tests/simplStg/should_compile/all.T
+++ b/testsuite/tests/simplStg/should_compile/all.T
@@ -12,3 +12,5 @@ setTestOpts(f)
 test('T13588', [ grep_errmsg('case') ] , compile, ['-dverbose-stg2stg -fno-worker-wrapper'])
 test('T19717', normal, compile, ['-ddump-stg-final -dsuppress-uniques -dno-typeable-binds'])
 test('inferTags002', [ only_ways(['optasm']), grep_errmsg('(call stg\_ap\_0)', [1])], compile, ['-ddump-cmm -dsuppress-uniques -dno-typeable-binds -O'])
+
+test('T22212', normal, compile, ['-O'])