Implement shrinkSmallMutableArray# and resizeSmallMutableArray#.

This is a part of GHC Proposal #25: "Offer more array resizing primitives".
Resources related to the proposal:

  - Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/121
  - Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0025-resize-boxed.rst

Only shrinkSmallMutableArray# is implemented as a primop since a
library-space implementation of resizeSmallMutableArray# (in GHC.Exts)
is no less efficient than a primop would be. This may be replaced by
a primop in the future if someone devises a strategy for growing
arrays in-place. The library-space implementation always copies the
array when growing it.

This commit also tweaks the documentation of the deprecated
sizeofMutableByteArray#, removing the mention of concurrency. That
primop is unsound even in single-threaded applications. Additionally,
the non-negativity assertion on the existing shrinkMutableByteArray#
primop has been removed since this predicate is trivially always true.

3 files changed, 90 insertions, 0 deletions

diff --git a/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayA.hs b/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayA.hs
new file mode 100644
index 0000000000..9202bcfffb
--- /dev/null
+++ b/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayA.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Monad (unless)
+import GHC.Exts
+import GHC.Types
+
+-- This test is nearly a copy of T11296. In T11296, it is
+-- shrinkMutableByteArray# that is tested. Here, it is
+-- shrinkSmallMutableArray# that is tested.
+
+data SmallArray = SA (SmallMutableArray# RealWorld Integer)
+
+main :: IO ()
+main = do
+    let element = 42 :: Integer
+    ba# <- IO (\s0 -> case newSmallArray# 256# element s0 of
+                        (# s1, ba# #) -> (# s1, SA ba# #))
+    let go n = do
+            shrink ba# n
+            sz <- getSize ba#
+            unless (sz == n) $ print (sz, n)
+    mapM go [128, 64, 63, 32, 2, 1]
+    return ()
+
+shrink :: SmallArray -> Int -> IO ()
+shrink (SA ba#) (I# n#) = IO (\s ->
+    case shrinkSmallMutableArray# ba# n# s of
+      s' -> (# s', () #))
+
+getSize :: SmallArray -> IO Int
+getSize (SA ba#) = IO (\s ->
+    case getSizeofSmallMutableArray# ba# s of
+      (# s', n# #) -> (# s', I# n# #))
+
diff --git a/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayB.hs b/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayB.hs
new file mode 100644
index 0000000000..c720c9da14
--- /dev/null
+++ b/testsuite/tests/primops/should_run/ShrinkSmallMutableArrayB.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Prelude hiding (read)
+import Control.Monad (unless)
+import GHC.Exts
+import GHC.Types
+import System.Mem (performMajorGC)
+
+-- The purpose of this test is to confirm that when the GC
+-- copies (out of the nursery) a SmallMutableArray# that has
+-- been shrunk, the array does not get corrupted.
+
+data SmallArray = SA (SmallMutableArray# RealWorld Integer)
+
+main :: IO ()
+main = do
+    let element = 42 :: Integer
+    arr <- IO (\s0 -> case newSmallArray# 30# element s0 of
+                        (# s1, ba# #) -> (# s1, SA ba# #))
+    write arr 0 100
+    write arr 13 113
+    write arr 14 114
+    write arr 15 115
+    write arr 16 116
+    shrink arr 14
+    performMajorGC
+    newSz <- getSize arr
+    unless (newSz == 14) (fail "Wrong new size")
+    e0 <- read arr 0
+    unless (e0 == 100) $
+      fail ("Wrong element 0: expected 100 but got " ++ show e0)
+    e13 <- read arr 13
+    unless (e13 == 113) $
+      fail ("Wrong element 13: expected 113 but got " ++ show e13)
+
+shrink :: SmallArray -> Int -> IO ()
+shrink (SA ba#) (I# n#) = IO (\s ->
+    case shrinkSmallMutableArray# ba# n# s of
+      s' -> (# s', () #))
+
+getSize :: SmallArray -> IO Int
+getSize (SA ba#) = IO (\s ->
+    case getSizeofSmallMutableArray# ba# s of
+      (# s', n# #) -> (# s', I# n# #))
+
+write :: SmallArray -> Int -> Integer -> IO ()
+write (SA ba#) (I# i#) e = IO (\s ->
+    case writeSmallArray# ba# i# e s of
+      s' -> (# s', () #))
+
+read :: SmallArray -> Int -> IO Integer
+read (SA ba#) (I# i#) = IO (\s -> readSmallArray# ba# i# s)
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index 6f5a04c5ed..bbcbdd8f78 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -26,3 +26,5 @@ test('ArithWord16', omit_ways(['ghci']), compile_and_run, [''])
 
 test('CmpInt16', normal, compile_and_run, [''])
 test('CmpWord16', normal, compile_and_run, [''])
+test('ShrinkSmallMutableArrayA', normal, compile_and_run, [''])
+test('ShrinkSmallMutableArrayB', normal, compile_and_run, [''])