diff options
author | sheaf <sam.derbyshire@gmail.com> | 2022-01-17 10:48:11 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-01-26 12:01:45 -0500 |
commit | e471a6803842db93483526f2be58b61ea3c33dc7 (patch) | |
tree | e07383ab88832f5ae806e4b04a8a734061b60dde /testsuite/tests | |
parent | 781323a3076781b5db50bdbeb8f64394add43836 (diff) | |
download | haskell-e471a6803842db93483526f2be58b61ea3c33dc7.tar.gz |
Levity-polymorphic arrays and mutable variables
This patch makes the following types levity-polymorphic in their
last argument:
- Array# a, SmallArray# a, Weak# b, StablePtr# a, StableName# a
- MutableArray# s a, SmallMutableArray# s a,
MutVar# s a, TVar# s a, MVar# s a, IOPort# s a
The corresponding primops are also made levity-polymorphic, e.g.
`newArray#`, `readArray#`, `writeMutVar#`, `writeIOPort#`, etc.
Additionally, exception handling functions such as `catch#`, `raise#`,
`maskAsyncExceptions#`,... are made levity/representation-polymorphic.
Now that Array# and MutableArray# also work with unlifted types,
we can simply re-define ArrayArray# and MutableArrayArray# in terms
of them. This means that ArrayArray# and MutableArrayArray# are no
longer primitive types, but simply unlifted newtypes around Array# and
MutableArrayArray#.
This completes the implementation of the Pointer Rep proposal
https://github.com/ghc-proposals/ghc-proposals/pull/203
Fixes #20911
-------------------------
Metric Increase:
T12545
-------------------------
-------------------------
Metric Decrease:
T12545
-------------------------
Diffstat (limited to 'testsuite/tests')
35 files changed, 609 insertions, 2 deletions
diff --git a/testsuite/tests/array/should_run/arr020.hs b/testsuite/tests/array/should_run/arr020.hs index 0dacf78216..dca7c2e64b 100644 --- a/testsuite/tests/array/should_run/arr020.hs +++ b/testsuite/tests/array/should_run/arr020.hs @@ -2,8 +2,7 @@ module Main where -import GHC.Prim -import GHC.Base +import GHC.Exts import GHC.ST import GHC.Word import Control.Monad diff --git a/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs b/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs new file mode 100644 index 0000000000..366cebeed2 --- /dev/null +++ b/testsuite/tests/primops/should_compile/UnliftedMutVar_Comp.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE UnboxedTuples, MagicHash #-} + +module UnliftedMutVar_Comp where + +import GHC.Exts + +readForCAS# :: MutVar# RealWorld a -> State# RealWorld -> (# State# RealWorld, a #) +readForCAS# = unsafeCoerce# readMutVar# + + -- this used to cause a panic in boxedRepDataCon, because a levity variable + -- was being defaulted to 'Any' instead of 'Lifted'. diff --git a/testsuite/tests/primops/should_compile/UnliftedStableName.hs b/testsuite/tests/primops/should_compile/UnliftedStableName.hs new file mode 100644 index 0000000000..2507646983 --- /dev/null +++ b/testsuite/tests/primops/should_compile/UnliftedStableName.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# Int# + +main :: IO () +main = do + IO \ s0 -> + case makeStableName# (U 97531# 86420#) s0 of + (# s1, nm1 #) -> + case makeStableName# (U 86420# 97531#) s1 of + (# s2, nm2 #) -> + case makeStableName# (U 97531# 86420#) s1 of + (# s3, nm3 #) -> + (# s3, () #) diff --git a/testsuite/tests/primops/should_compile/all.T b/testsuite/tests/primops/should_compile/all.T index 1613313748..023eeaedce 100644 --- a/testsuite/tests/primops/should_compile/all.T +++ b/testsuite/tests/primops/should_compile/all.T @@ -2,3 +2,5 @@ test('T6135_should_compile', normal, compile, ['']) test('T16293a', normal, compile, ['']) test('T19851', normal, compile, ['-O']) test('LevPolyPtrEquality3', normal, compile, ['']) +test('UnliftedMutVar_Comp', normal, compile, ['']) +test('UnliftedStableName', normal, compile, [''])
\ No newline at end of file diff --git a/testsuite/tests/primops/should_run/UnliftedArray1.hs b/testsuite/tests/primops/should_run/UnliftedArray1.hs new file mode 100644 index 0000000000..c8c401d8da --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newArray# 4# (41 :: Int) s0 of + (# s1, marr1 #) -> + case newArray# 7# (11 :: Int) s1 of + (# s2, marr2 #) -> + case unsafeFreezeArray# marr1 s2 of + (# s3, arr1 #) -> + case unsafeFreezeArray# marr2 s3 of + (# s4, arr2 #) -> + case newArray# 3# arr1 s4 of + (# s5, marrarr #) -> + case writeArray# marrarr 2# arr2 s5 of + s6 -> + case unsafeFreezeArray# marrarr s6 of + (# s7, arrarr #) -> + case indexArray# arrarr 2# of + (# read_arr_2 #) -> + case indexArray# arrarr 0# of + (# read_arr_0 #) -> + case indexArray# read_arr_2 6# of + (# val_11 #) -> + case indexArray# read_arr_0 3# of + (# val_41 #) -> + (# s7, [I# (sizeofArray# arrarr), val_11, val_41] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArray1.stdout b/testsuite/tests/primops/should_run/UnliftedArray1.stdout new file mode 100644 index 0000000000..dcfcf2beb2 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray1.stdout @@ -0,0 +1 @@ +[3,11,41] diff --git a/testsuite/tests/primops/should_run/UnliftedArray2.hs b/testsuite/tests/primops/should_run/UnliftedArray2.hs new file mode 100644 index 0000000000..490d183416 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray2.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U !Int + +main :: IO () +main = do + res <- IO \ s1 -> + case newArray# 7# (U 3) s1 of + (# s2, marr1 #) -> + case newArray# 9# (U 8) s2 of + (# s3, marr2 #) -> + case copyMutableArray# marr1 2# marr2 1# 3# s3 of + s4 -> + case writeArray# marr1 3# (U 11) s4 of + s5 -> + case freezeArray# marr2 0# 8# s5 of + (# s6, arr2 #) -> + case copyArray# arr2 1# marr2 1# 1# s6 of + s7 -> + case readArray# marr2 2# s7 of + (# s8, U val1 #) -> + case thawArray# arr2 1# 7# s8 of + (# s9, marr2' #) -> + case readArray# marr2' 5# s9 of + (# s10, U val2 #) -> + (# s10, [I# (sizeofMutableArray# marr2), val1, val2] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArray2.stdout b/testsuite/tests/primops/should_run/UnliftedArray2.stdout new file mode 100644 index 0000000000..386319ed6e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArray2.stdout @@ -0,0 +1 @@ +[9,3,8] diff --git a/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs b/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs new file mode 100644 index 0000000000..2002573e5e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArrayCAS.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + let star = U 1612# + res <- IO \ s0 -> + case newArray# 10# star s0 of + (# s1, arr #) -> + case readArray# arr 7# s1 of + (# s2, U v0 #) -> + case casArray# arr 7# star (U 1728#) s2 of + (# s2, i, U f #) -> + case casArray# arr 7# star (U 1989#) s2 of + (# s3, j, U g #) -> + (# s3, [ I# v0, I# i, I# f, I# j, I# g ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout b/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout new file mode 100644 index 0000000000..98711e8b25 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedArrayCAS.stdout @@ -0,0 +1 @@ +[1612,0,1728,1,1728] diff --git a/testsuite/tests/primops/should_run/UnliftedIOPort.hs b/testsuite/tests/primops/should_run/UnliftedIOPort.hs new file mode 100644 index 0000000000..7bdf0dff7a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedIOPort.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: Type +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newIOPort# s0 of + (# s1, port #) -> + case writeIOPort# port (U 17#) s1 of + (# s2, i #) -> + case catch# (writeIOPort# port (U 19#)) (\ _ s -> (# s, 3# #)) s2 of + (# s3, j #) -> + case readIOPort# port s3 of + (# s4, U r1 #) -> + case catch# (readIOPort# port) (\ _ s -> (# s, U 4# #)) s4 of + (# s5, U r2 #) -> + (# s5, [ I# i, I# j, I# r1, I# r2 ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedIOPort.stdout b/testsuite/tests/primops/should_run/UnliftedIOPort.stdout new file mode 100644 index 0000000000..0b8c2d48bf --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedIOPort.stdout @@ -0,0 +1 @@ +[1,3,17,4] diff --git a/testsuite/tests/primops/should_run/UnliftedMVar.hs b/testsuite/tests/primops/should_run/UnliftedMVar.hs new file mode 100644 index 0000000000..2f4349b622 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMVar.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMVar# s0 of + (# s1, mvar #) -> + case tryTakeMVar# mvar s1 of + (# s2, i, _ #) -> + case putMVar# mvar (U 1612#) s2 of + s3 -> + case readMVar# mvar s3 of + (# s4, U r1 #) -> + case takeMVar# mvar s4 of + (# s5, U r2 #) -> + case tryReadMVar# mvar s5 of + (# s6, j, _ #) -> + case isEmptyMVar# mvar s6 of + (# s7, k #) -> + (# s6, [ I# i, I# r1, I# r2, I# j, I# k ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMVar.stdout b/testsuite/tests/primops/should_run/UnliftedMVar.stdout new file mode 100644 index 0000000000..60db051318 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMVar.stdout @@ -0,0 +1 @@ +[0,1612,1612,0,1] diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar1.hs b/testsuite/tests/primops/should_run/UnliftedMutVar1.hs new file mode 100644 index 0000000000..12d77e6712 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar1.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# (41 :: Int) s0 of + (# s1, mvar #) -> + case newMutVar# mvar s1 of + (# s2, mvarmvar #) -> + case writeMutVar# mvar (17 :: Int) s2 of + s3 -> + case readMutVar# mvarmvar s3 of + (# s4, read_mvar #) -> + readMutVar# read_mvar s4 + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout new file mode 100644 index 0000000000..98d9bcb75a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar1.stdout @@ -0,0 +1 @@ +17 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar2.hs b/testsuite/tests/primops/should_run/UnliftedMutVar2.hs new file mode 100644 index 0000000000..fe657560ea --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# (U 0#) s0 of + (# s1, var #) -> + sum_squares var s1 + print res + +sum_squares :: MutVar# s U -> State# s -> (# State# s, Int #) +sum_squares var s = case go s of { (# s', i #) -> (# s', I# i #) } + where + go s0 = case readMutVar# var s0 of + (# s1, U val #) + | I# val >= 1000000 + -> (# s1, val #) + | otherwise + -> let nxt = val +# 1# + in case writeMutVar# var (U (val +# nxt *# nxt)) s1 of + s2 -> go s2 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout new file mode 100644 index 0000000000..a055fad337 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar2.stdout @@ -0,0 +1 @@ +3263441 diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar3.hs b/testsuite/tests/primops/should_run/UnliftedMutVar3.hs new file mode 100644 index 0000000000..fab8192aca --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar3.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = X | Y + +showU :: U -> String +showU X = "X" +showU Y = "Y" + +main :: IO () +main = do + res <- IO \ s0 -> + case newMutVar# X s0 of + (# s1, mvar #) -> + case readMutVar# mvar s1 of + (# s2, r1 #) -> + case writeMutVar# mvar Y s2 of + s3 -> case readMutVar# mvar s3 of + (# s4, r2 #) -> + (# s4, [ showU r1, showU r2 ] #) + putStrLn (unwords res) diff --git a/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout b/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout new file mode 100644 index 0000000000..f4c2719cb7 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVar3.stdout @@ -0,0 +1 @@ +X Y diff --git a/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs new file mode 100644 index 0000000000..9559467c6c --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + let star = U 1612# + res <- IO \ s0 -> + case newMutVar# star s0 of + (# s1, var #) -> + case readMutVar# var s1 of + (# s2, U v0 #) -> + case casMutVar# var star (U 1728#) s2 of + (# s3, i, U f #) -> + case casMutVar# var star (U 1989#) s3 of + (# s4, j, U g #) -> + (# s4, [ I# v0, I# i, I# f, I# j, I# g ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout new file mode 100644 index 0000000000..98711e8b25 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedMutVarCAS.stdout @@ -0,0 +1 @@ +[1612,0,1728,1,1728] diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs b/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs new file mode 100644 index 0000000000..50556b5b54 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + res <- IO \ s0 -> + case newSmallArray# 4# (41 :: Int) s0 of + (# s1, marr1 #) -> + case newSmallArray# 7# (11 :: Int) s1 of + (# s2, marr2 #) -> + case unsafeFreezeSmallArray# marr1 s2 of + (# s3, arr1 #) -> + case unsafeFreezeSmallArray# marr2 s3 of + (# s4, arr2 #) -> + case newSmallArray# 3# arr1 s4 of + (# s5, marrarr #) -> + case writeSmallArray# marrarr 2# arr2 s5 of + s6 -> + case unsafeFreezeSmallArray# marrarr s6 of + (# s7, arrarr #) -> + case indexSmallArray# arrarr 2# of + (# read_arr_2 #) -> + case indexSmallArray# arrarr 0# of + (# read_arr_0 #) -> + case indexSmallArray# read_arr_2 6# of + (# val_11 #) -> + case indexSmallArray# read_arr_0 3# of + (# val_41 #) -> + (# s7, [I# (sizeofSmallArray# arrarr), val_11, val_41] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout b/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout new file mode 100644 index 0000000000..dcfcf2beb2 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray1.stdout @@ -0,0 +1 @@ +[3,11,41] diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs b/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs new file mode 100644 index 0000000000..34f894c07f --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U !Int + +main :: IO () +main = do + res <- IO \ s1 -> + case newSmallArray# 7# (U 3) s1 of + (# s2, marr1 #) -> + case newSmallArray# 9# (U 8) s2 of + (# s3, marr2 #) -> + case copySmallMutableArray# marr1 2# marr2 1# 3# s3 of + s4 -> + case writeSmallArray# marr1 3# (U 11) s4 of + s5 -> + case freezeSmallArray# marr2 0# 8# s5 of + (# s6, arr2 #) -> + case copySmallArray# arr2 1# marr2 1# 1# s6 of + s7 -> + case readSmallArray# marr2 2# s7 of + (# s8, U val1 #) -> + case thawSmallArray# arr2 1# 7# s8 of + (# s9, marr2' #) -> + case shrinkSmallMutableArray# marr2' 6# s9 of + s10 -> + case readSmallArray# marr2' 5# s10 of + (# s11, U val2 #) -> + case getSizeofSmallMutableArray# marr2' s11 of + (# s12, sz #) -> + (# s12, [I# sz, val1, val2] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout b/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout new file mode 100644 index 0000000000..750263349e --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedSmallArray2.stdout @@ -0,0 +1 @@ +[6,3,8] diff --git a/testsuite/tests/primops/should_run/UnliftedStablePtr.hs b/testsuite/tests/primops/should_run/UnliftedStablePtr.hs new file mode 100644 index 0000000000..1b973ead87 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedStablePtr.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import System.Mem (performGC) +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# Int# + +main :: IO () +main = do + res <- IO \ s0 -> + let u :: U + u = U 97531# 86420# + in + case makeStablePtr# u s0 of + (# s1, ptr #) -> + case unIO performGC s1 of + (# s3, _ #) -> + case deRefStablePtr# ptr s3 of + (# s4, U i j #) -> + case makeStablePtr# (U 123# 456#) s4 of + (# s5, ptr' #) -> + (# s5, [ I# i, I# j, I# (eqStablePtr# ptr ptr), I# (eqStablePtr# ptr ptr') ] #) + print res diff --git a/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout b/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout new file mode 100644 index 0000000000..4a9e91e841 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedStablePtr.stdout @@ -0,0 +1 @@ +[97531,86420,1,0] diff --git a/testsuite/tests/primops/should_run/UnliftedTVar1.hs b/testsuite/tests/primops/should_run/UnliftedTVar1.hs new file mode 100644 index 0000000000..a576d11f9a --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar1.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newTVar# (U 1612#) s0 of + (# s1, tvar #) -> + case atomically# (readAndWrite tvar) s1 of + (# s2, U r #) -> + case readTVarIO# tvar s2 of + (# s3, U res #) -> + (# s3, [ I# r, I# res ] #) + print res + +readAndWrite :: TVar# s U -> State# s -> (# State# s, U #) +readAndWrite tvar = go + where + go s0 = + case readTVar# tvar s0 of + (# s1, U i #) -> + case writeTVar# tvar (U (i *# 100#)) s1 of + s2 -> (# s2, U i #) diff --git a/testsuite/tests/primops/should_run/UnliftedTVar1.stdout b/testsuite/tests/primops/should_run/UnliftedTVar1.stdout new file mode 100644 index 0000000000..d27bb7d2e8 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar1.stdout @@ -0,0 +1 @@ +[1612,161200] diff --git a/testsuite/tests/primops/should_run/UnliftedTVar2.hs b/testsuite/tests/primops/should_run/UnliftedTVar2.hs new file mode 100644 index 0000000000..70cbce18a8 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar2.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + (x,y) <- IO \ s0 -> + case newTVar# (U 0#) s0 of + (# s1, tvar #) -> + case fork# (increment tvar) s1 of + (# s2, t_id #) -> + case atomically# (readUntil tvar) s2 of + (# s3, U r #) -> + case killThread# t_id 13 s3 of + s4 -> + case readTVarIO# tvar s4 of + (# s5, U res #) -> + (# s5, ( I# r, I# res ) #) + print (x == y, x > 100000) + +increment :: TVar# RealWorld U -> State# RealWorld -> (# State# RealWorld, Int #) +increment tvar = go + where + go :: State# RealWorld -> (# State# RealWorld, Int #) + go s0 = case atomically# inc s0 of + (# s1, res #) -> go s1 + + inc :: State# RealWorld -> (# State# RealWorld, Int #) + inc s0 = + case readTVar# tvar s0 of + (# s1, U v #) -> + case writeTVar# tvar (U (v +# 1#)) s1 of + s2 -> (# s2, I# v #) + +readUntil :: TVar# RealWorld U -> State# RealWorld -> (# State# RealWorld, U #) +readUntil tvar = go + where + go s0 = + case readTVar# tvar s0 of + (# s1, r@(U i) #) + | I# i >= 100000 + -> (# s1, r #) + | otherwise + -> retry# s1 diff --git a/testsuite/tests/primops/should_run/UnliftedTVar2.stdout b/testsuite/tests/primops/should_run/UnliftedTVar2.stdout new file mode 100644 index 0000000000..1fa0b54b36 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedTVar2.stdout @@ -0,0 +1 @@ +(True,True) diff --git a/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs b/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs new file mode 100644 index 0000000000..d957485eba --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedWeakPtr.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Data.Kind +import System.Mem (performGC) +import GHC.Exts +import GHC.IO + +type U :: UnliftedType +data U = U Int# + +main :: IO () +main = do + res <- IO \ s0 -> + case newMVar# s0 of + (# s1, mvar #) -> + case newMutVar# False s1 of + (# s2, val_var #) -> + case keepAlive# val_var s2 (inner mvar val_var) of + (# s3, wk, strs #) -> + case unIO performGC s3 of + (# s4, _ #) -> + case deRefWeak# wk s4 of + (# s5, j, _ #) -> + case takeMVar# mvar s5 of + (# s6, r #) -> + (# s6, strs ++ [ show (I# j), r ] #) + print res + +inner :: MVar# RealWorld String + -> MutVar# RealWorld Bool + -> State# RealWorld + -> (# State# RealWorld, Weak# U, [String] #) +inner mvar u s0 = + case mkWeak# u (U 42#) (finalise mvar) s0 of + (# s1, wk #) -> + case deRefWeak# wk s1 of + (# s2, i, U u #) -> (# s2, wk, [ show (I# i), show (I# u) ] #) + +finalise :: MVar# RealWorld String -> State# RealWorld -> (# State# RealWorld, () #) +finalise mvar s0 = + case putMVar# mvar "finalised!" s0 of + s1 -> (# s1, () #) diff --git a/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout b/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout new file mode 100644 index 0000000000..327ad4fa74 --- /dev/null +++ b/testsuite/tests/primops/should_run/UnliftedWeakPtr.stdout @@ -0,0 +1 @@ +["1","42","0","finalised!"] diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T index ef046f34ae..b4a4b1f612 100644 --- a/testsuite/tests/primops/should_run/all.T +++ b/testsuite/tests/primops/should_run/all.T @@ -41,3 +41,19 @@ test('Sized', normal, compile_and_run, ['']) test('LevPolyPtrEquality1', normal, compile_and_run, ['']) test('LevPolyPtrEquality2', normal, compile_and_run, ['']) + +test('UnliftedArray1', normal, compile_and_run, ['']) +test('UnliftedArray2', normal, compile_and_run, ['']) +test('UnliftedArrayCAS', normal, compile_and_run, ['']) +test('UnliftedIOPort', normal, compile_and_run, ['']) +test('UnliftedMutVar1', normal, compile_and_run, ['']) +test('UnliftedMutVar2', normal, compile_and_run, ['']) +test('UnliftedMutVar3', normal, compile_and_run, ['']) +test('UnliftedMutVarCAS', normal, compile_and_run, ['']) +test('UnliftedMVar', normal, compile_and_run, ['']) +test('UnliftedSmallArray1', normal, compile_and_run, ['']) +test('UnliftedSmallArray2', normal, compile_and_run, ['']) +test('UnliftedStablePtr', normal, compile_and_run, ['']) +test('UnliftedTVar1', normal, compile_and_run, ['']) +test('UnliftedTVar2', normal, compile_and_run, ['']) +test('UnliftedWeakPtr', normal, compile_and_run, ['']) |