diff options
Diffstat (limited to 'testsuite')
8 files changed, 84 insertions, 0 deletions
diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs new file mode 100644 index 0000000000..b5c3da4f91 --- /dev/null +++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} + +module LevPolyPtrEquality3 where + +import GHC.Exts + ( Int# + , unsafeCoerce#, reallyUnsafePtrEquality# + ) + +f :: a -> b -> Int# +f a b = unsafeCoerce# reallyUnsafePtrEquality# a b diff --git a/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr new file mode 100644 index 0000000000..279f32428b --- /dev/null +++ b/testsuite/tests/primops/should_fail/LevPolyPtrEquality3.stderr @@ -0,0 +1,11 @@ + +LevPolyPtrEquality3.hs:11:23: error: + Cannot use function with representation-polymorphic arguments: + reallyUnsafePtrEquality# :: GHC.Types.Any -> GHC.Types.Any -> Int# + (Note that representation-polymorphic primops, + such as 'coerce' and unboxed tuples, are eta-expanded + internally because they must occur fully saturated. + Use -fprint-typechecker-elaboration to display the full expression.) + Representation-polymorphic arguments: + GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any) + GHC.Types.Any :: TYPE ('GHC.Types.BoxedRep GHC.Types.Any) diff --git a/testsuite/tests/primops/should_fail/all.T b/testsuite/tests/primops/should_fail/all.T new file mode 100644 index 0000000000..f599102c23 --- /dev/null +++ b/testsuite/tests/primops/should_fail/all.T @@ -0,0 +1 @@ +test('LevPolyPtrEquality3', normal, compile_fail, ['']) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs new file mode 100644 index 0000000000..bbd4819c7d --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +data ByteArray = ByteArray ByteArray# + +mkTwoByteArrays :: IO ( ByteArray, ByteArray ) +mkTwoByteArrays = IO \ s1 -> case newPinnedByteArray# 32# s1 of + (# s2, mba1 #) -> case unsafeFreezeByteArray# mba1 s2 of + (# s3, ba1 #) -> case newPinnedByteArray# 32# s3 of + (# s4, mba2 #) -> case unsafeFreezeByteArray# mba2 s4 of + (# s5, ba2 #) -> (# s5, ( ByteArray ba1, ByteArray ba2 ) #) + +main :: IO () +main = do + ( ByteArray ba1, ByteArray ba2 ) <- mkTwoByteArrays + putStr "eq 1 2: " + print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba2 ) + putStr "eq 1 1: " + print $ isTrue# ( reallyUnsafePtrEquality# ba1 ba1 ) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout new file mode 100644 index 0000000000..aaf2e46dcf --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality1.stdout @@ -0,0 +1,2 @@ +eq 1 2: False +eq 1 1: True diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs new file mode 100644 index 0000000000..ef52bd3de1 --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.Types + +data PEither a b :: UnliftedType where + PLeft :: a -> PEither a b + PRight :: b -> PEither a b + +main :: IO () +main = do + let + a, b, c :: PEither Bool Int + a = PRight 1 + b = case a of { PLeft a -> PLeft (not a) ; r -> r } + c = PLeft False + d :: Either Bool Int + d = Right 1 + putStr "eq a b: " + print $ isTrue# ( reallyUnsafePtrEquality# a b ) + putStr "eq a c: " + print $ isTrue# ( reallyUnsafePtrEquality# a c ) + putStr "eq a d: " + print $ isTrue# ( reallyUnsafePtrEquality# a d ) diff --git a/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout new file mode 100644 index 0000000000..b06eeb90d0 --- /dev/null +++ b/testsuite/tests/primops/should_run/LevPolyPtrEquality2.stdout @@ -0,0 +1,3 @@ +eq a b: True +eq a c: False +eq a d: False diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index cad58c1909..ef046f34ae 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -38,3 +38,6 @@ test('T14664', normal, compile_and_run, ['']) test('CStringLength', normal, compile_and_run, ['-O2']) test('NonNativeSwitch', normal, compile_and_run, ['-O2']) test('Sized', normal, compile_and_run, ['']) + +test('LevPolyPtrEquality1', normal, compile_and_run, ['']) +test('LevPolyPtrEquality2', normal, compile_and_run, ['']) |