diff options
-rw-r--r-- | testsuite/tests/primops/should_compile/LevAddrToAny.hs | 44 | ||||
-rw-r--r-- | testsuite/tests/primops/should_compile/all.T | 1 |
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']) |