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
-------------------------

31 files changed, 568 insertions, 0 deletions

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, [''])