summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsheaf <sam.derbyshire@gmail.com>2022-09-20 20:55:19 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-09-21 08:28:49 -0400
commit06ccad0de07026ea8128a9951f608bcc67ef23d8 (patch)
tree9a6625567735fe79d5b0c5d642dee29c66cbea8b
parenta971657d5c4e919a8d446386374e5ed491e9f6b9 (diff)
downloadhaskell-06ccad0de07026ea8128a9951f608bcc67ef23d8.tar.gz
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
-rw-r--r--compiler/GHC/Stg/InferTags/Rewrite.hs15
-rw-r--r--testsuite/tests/simplStg/should_compile/T22212.hs45
-rw-r--r--testsuite/tests/simplStg/should_compile/all.T2
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'])