[Git][ghc/ghc][master] Don't use isUnliftedType in isTagged

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
06ccad0d by sheaf at 2022-09-21T08:28:49-04:00
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 changed files:

- compiler/GHC/Stg/InferTags/Rewrite.hs
- + testsuite/tests/simplStg/should_compile/T22212.hs
- testsuite/tests/simplStg/should_compile/all.T


Changes:

=====================================
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


=====================================
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


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06ccad0de07026ea8128a9951f608bcc67ef23d8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/06ccad0de07026ea8128a9951f608bcc67ef23d8
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220921/a03d1afd/attachment-0001.html>