summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--testsuite/tests/primops/should_compile/LevAddrToAny.hs44
-rw-r--r--testsuite/tests/primops/should_compile/all.T1
2 files changed, 45 insertions, 0 deletions
diff --git a/testsuite/tests/primops/should_compile/LevAddrToAny.hs b/testsuite/tests/primops/should_compile/LevAddrToAny.hs
new file mode 100644
index 0000000000..ff3db69817
--- /dev/null
+++ b/testsuite/tests/primops/should_compile/LevAddrToAny.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE MagicHash, TypeApplications, UnliftedDatatypes, KindSignatures, UnboxedTuples #-}
+
+module LevAddrToAny where
+
+import GHC.Exts
+ ( Int#
+ , Int (I#)
+ , addrToAny#
+ , Addr#
+ , ByteArray#
+ , UnliftedType
+ , proxy#
+ )
+
+import Data.Proxy (Proxy (..))
+import Data.Kind (Type)
+
+
+addrToAnyLifted :: forall (x :: Type). Addr# -> x
+addrToAnyLifted addr = case addrToAny# addr of (# x #) -> x
+
+addrToAnyUnlifted :: forall (x :: UnliftedType). Addr# -> x
+addrToAnyUnlifted addr = case addrToAny# addr of (# x #) -> x
+
+addrToUnit :: Addr# -> ()
+addrToUnit = addrToAnyLifted @()
+
+addrToInt :: Addr# -> Int
+addrToInt = addrToAnyLifted @Int
+
+type UnlUnit :: UnliftedType
+data UnlUnit = UnlUnit
+
+addrToUnlUnit :: Addr# -> UnlUnit
+addrToUnlUnit = addrToAnyUnlifted
+
+type Box :: UnliftedType -> Type
+data Box a = Box a
+
+addrToBoxedUnlUnit :: Addr# -> Box UnlUnit
+addrToBoxedUnlUnit a = Box (addrToAnyUnlifted a)
+
+addrToBoxByteArr :: Addr# -> Box ByteArray#
+addrToBoxByteArr a = Box (addrToAnyUnlifted a)
diff --git a/testsuite/tests/primops/should_compile/all.T b/testsuite/tests/primops/should_compile/all.T
index 5b4dcd82df..82fa474c8b 100644
--- a/testsuite/tests/primops/should_compile/all.T
+++ b/testsuite/tests/primops/should_compile/all.T
@@ -2,6 +2,7 @@ test('T6135_should_compile', normal, compile, [''])
test('T16293a', normal, compile, [''])
test('T19851', normal, compile, ['-O'])
test('LevPolyPtrEquality3', normal, compile, [''])
+test('LevAddrToAny', normal, compile, [''])
test('UnliftedMutVar_Comp', normal, compile, [''])
test('UnliftedStableName', normal, compile, [''])
test('KeepAliveWrapper', normal, compile, ['-O'])