summaryrefslogtreecommitdiff
path: root/testsuite/tests/codeGen
diff options
context:
space:
mode:
authorJohan Tibell <johan.tibell@gmail.com>2014-03-23 12:06:56 +0100
committerJohan Tibell <johan.tibell@gmail.com>2014-03-29 11:24:07 +0100
commit90329b6cc183b3cd05956ae6bdeb6ac6951549c2 (patch)
treeba7d31656fe75fad2555c8a66b7ebd13dd9ebeb1 /testsuite/tests/codeGen
parent4c8edfd2c722504baaa6896d194fd3a8c3f9b652 (diff)
downloadhaskell-90329b6cc183b3cd05956ae6bdeb6ac6951549c2.tar.gz
Add SmallArray# and SmallMutableArray# types
These array types are smaller than Array# and MutableArray# and are faster when the array size is small, as they don't have the overhead of a card table. Having no card table reduces the closure size with 2 words in the typical small array case and leads to less work when updating or GC:ing the array. Reduces both the runtime and memory allocation by 8.8% on my insert benchmark for the HashMap type in the unordered-containers package, which makes use of lots of small arrays. With tuned GC settings (i.e. `+RTS -A6M`) the runtime reduction is 15%. Fixes #8923.
Diffstat (limited to 'testsuite/tests/codeGen')
-rw-r--r--testsuite/tests/codeGen/should_run/CopySmallArray.hs300
-rw-r--r--testsuite/tests/codeGen/should_run/CopySmallArray.stdout24
-rw-r--r--testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs387
-rw-r--r--testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout2
-rw-r--r--testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs32
-rw-r--r--testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout4
-rw-r--r--testsuite/tests/codeGen/should_run/all.T3
7 files changed, 752 insertions, 0 deletions
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArray.hs b/testsuite/tests/codeGen/should_run/CopySmallArray.hs
new file mode 100644
index 0000000000..6902fe2db2
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CopySmallArray.hs
@@ -0,0 +1,300 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- !!! simple tests of copying/cloning primitive arrays
+--
+
+module Main ( main ) where
+
+import GHC.Exts hiding (IsList(..))
+import GHC.Prim
+import GHC.ST
+
+main :: IO ()
+main = putStr
+ (test_copyArray
+ ++ "\n" ++ test_copyMutableArray
+ ++ "\n" ++ test_copyMutableArrayOverlap
+ ++ "\n" ++ test_cloneArray
+ ++ "\n" ++ test_cloneArrayStatic
+ ++ "\n" ++ test_cloneMutableArray
+ ++ "\n" ++ test_cloneMutableArrayEmpty
+ ++ "\n" ++ test_cloneMutableArrayStatic
+ ++ "\n" ++ test_freezeArray
+ ++ "\n" ++ test_freezeArrayStatic
+ ++ "\n" ++ test_thawArray
+ ++ "\n" ++ test_thawArrayStatic
+ ++ "\n"
+ )
+
+------------------------------------------------------------------------
+-- Constants
+
+-- All allocated arrays are of this size
+len :: Int
+len = 130
+
+-- We copy these many elements
+copied :: Int
+copied = len - 2
+
+copiedStatic :: Int
+copiedStatic = 16
+{-# INLINE copiedStatic #-} -- to make sure optimization triggers
+
+------------------------------------------------------------------------
+-- copySmallArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyArray :: String
+test_copyArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ src <- unsafeFreezeArray src
+ dst <- newArray len (-1)
+ -- Leave the first and last element untouched
+ copyArray src 1 dst 1 copied
+ unsafeFreezeArray dst
+ in shows (toList dst len) "\n"
+
+------------------------------------------------------------------------
+-- copySmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: String
+test_copyMutableArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ dst <- newArray len (-1)
+ -- Leave the first and last element untouched
+ copyMutableArray src 1 dst 1 copied
+ unsafeFreezeArray dst
+ in shows (toList dst len) "\n"
+
+-- Perform a copy where the source and destination part overlap.
+test_copyMutableArrayOverlap :: String
+test_copyMutableArrayOverlap =
+ let arr = runST $ do
+ marr <- fromList inp
+ -- Overlap of two elements
+ copyMutableArray marr 5 marr 7 8
+ unsafeFreezeArray marr
+ in shows (toList arr (length inp)) "\n"
+ where
+ -- This case was known to fail at some point.
+ inp = [0,169,196,9,16,25,36,16,25,81,100,121,144,169,196]
+
+------------------------------------------------------------------------
+-- cloneSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_cloneArray :: String
+test_cloneArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ src <- unsafeFreezeArray src
+ -- Don't include the first and last element.
+ return $! cloneArray src 1 copied
+ in shows (toList dst copied) "\n"
+
+-- Check that the static-size optimization works.
+test_cloneArrayStatic :: String
+test_cloneArrayStatic =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ src <- unsafeFreezeArray src
+ -- Don't include the first and last element.
+ return $! cloneArray src 1 copiedStatic
+ in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- cloneMutableSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_cloneMutableArray :: String
+test_cloneMutableArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ -- Don't include the first and last element.
+ dst <- cloneMutableArray src 1 copied
+ unsafeFreezeArray dst
+ in shows (toList dst copied) "\n"
+
+-- Check that zero-length clones work.
+test_cloneMutableArrayEmpty :: String
+test_cloneMutableArrayEmpty =
+ let dst = runST $ do
+ src <- newArray len 0
+ dst <- cloneMutableArray src 0 0
+ unsafeFreezeArray dst
+ in shows (toList dst 0) "\n"
+
+-- Check that the static-size optimization works.
+test_cloneMutableArrayStatic :: String
+test_cloneMutableArrayStatic =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ -- Don't include the first and last element.
+ dst <- cloneMutableArray src 1 copiedStatic
+ unsafeFreezeArray dst
+ in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- freezeSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_freezeArray :: String
+test_freezeArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ -- Don't include the first and last element.
+ freezeArray src 1 copied
+ in shows (toList dst copied) "\n"
+
+-- Check that the static-size optimization works.
+test_freezeArrayStatic :: String
+test_freezeArrayStatic =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ -- Don't include the first and last element.
+ freezeArray src 1 copiedStatic
+ in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- thawSmallArray#
+
+-- Clone a slice of the source array into a destination array and
+-- check that the clone succeeded.
+test_thawArray :: String
+test_thawArray =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ src <- unsafeFreezeArray src
+ -- Don't include the first and last element.
+ dst <- thawArray src 1 copied
+ unsafeFreezeArray dst
+ in shows (toList dst copied) "\n"
+
+-- Check that the static-size optimization works.
+test_thawArrayStatic :: String
+test_thawArrayStatic =
+ let dst = runST $ do
+ src <- newArray len 0
+ fill src 0 len
+ src <- unsafeFreezeArray src
+ -- Don't include the first and last element.
+ dst <- thawArray src 1 copiedStatic
+ unsafeFreezeArray dst
+ in shows (toList dst copiedStatic) "\n"
+
+------------------------------------------------------------------------
+-- Test helpers
+
+-- Initialize the elements of this array, starting at the given
+-- offset. The last parameter specifies the number of elements to
+-- initialize. Element at index @i@ takes the value @i*i@ (i.e. the
+-- first actually modified element will take value @off*off@).
+fill :: MArray s Int -> Int -> Int -> ST s ()
+fill marr off count = go 0
+ where
+ go i
+ | i >= count = return ()
+ | otherwise = writeArray marr (off + i) (i*i) >> go (i + 1)
+
+fromList :: [Int] -> ST s (MArray s Int)
+fromList xs0 = do
+ marr <- newArray (length xs0) bottomElem
+ let go [] i = i `seq` return marr
+ go (x:xs) i = writeArray marr i x >> go xs (i + 1)
+ go xs0 0
+ where
+ bottomElem = error "undefined element"
+
+------------------------------------------------------------------------
+-- Convenience wrappers for SmallArray# and MutableSmallArray#
+
+data Array a = Array { unArray :: SmallArray# a }
+data MArray s a = MArray { unMArray :: SmallMutableArray# s a }
+
+newArray :: Int -> a -> ST s (MArray s a)
+newArray (I# n#) a = ST $ \s# -> case newSmallArray# n# a s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# #)
+
+indexArray :: Array a -> Int -> a
+indexArray arr i@(I# i#)
+ | i < 0 || i >= len =
+ error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
+ | otherwise = case indexSmallArray# (unArray arr) i# of
+ (# a #) -> a
+ where len = lengthArray arr
+
+writeArray :: MArray s a -> Int -> a -> ST s ()
+writeArray marr i@(I# i#) a
+ | i < 0 || i >= len =
+ error $ "bounds error, offset " ++ show i ++ ", length " ++ show len
+ | otherwise = ST $ \ s# ->
+ case writeSmallArray# (unMArray marr) i# a s# of
+ s2# -> (# s2#, () #)
+ where len = lengthMArray marr
+
+lengthArray :: Array a -> Int
+lengthArray arr = I# (sizeofSmallArray# (unArray arr))
+
+lengthMArray :: MArray s a -> Int
+lengthMArray marr = I# (sizeofSmallMutableArray# (unMArray marr))
+
+unsafeFreezeArray :: MArray s a -> ST s (Array a)
+unsafeFreezeArray marr = ST $ \ s# ->
+ case unsafeFreezeSmallArray# (unMArray marr) s# of
+ (# s2#, arr# #) -> (# s2#, Array arr# #)
+
+copyArray :: Array a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
+ case copySmallArray# (unArray src) six# (unMArray dst) dix# n# s# of
+ s2# -> (# s2#, () #)
+
+copyMutableArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMutableArray src (I# six#) dst (I# dix#) (I# n#) = ST $ \ s# ->
+ case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+ s2# -> (# s2#, () #)
+
+cloneArray :: Array a -> Int -> Int -> Array a
+cloneArray src (I# six#) (I# n#) = Array (cloneSmallArray# (unArray src) six# n#)
+{-# INLINE cloneArray #-} -- to make sure optimization triggers
+
+cloneMutableArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMutableArray src (I# six#) (I# n#) = ST $ \ s# ->
+ case cloneSmallMutableArray# (unMArray src) six# n# s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# #)
+{-# INLINE cloneMutableArray #-} -- to make sure optimization triggers
+
+freezeArray :: MArray s a -> Int -> Int -> ST s (Array a)
+freezeArray src (I# six#) (I# n#) = ST $ \ s# ->
+ case freezeSmallArray# (unMArray src) six# n# s# of
+ (# s2#, arr# #) -> (# s2#, Array arr# #)
+{-# INLINE freezeArray #-} -- to make sure optimization triggers
+
+thawArray :: Array a -> Int -> Int -> ST s (MArray s a)
+thawArray src (I# six#) (I# n#) = ST $ \ s# ->
+ case thawSmallArray# (unArray src) six# n# s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# #)
+{-# INLINE thawArray #-} -- to make sure optimization triggers
+
+toList :: Array a -> Int -> [a]
+toList arr n = go 0
+ where
+ go i | i >= n = []
+ | otherwise = indexArray arr i : go (i+1)
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArray.stdout b/testsuite/tests/codeGen/should_run/CopySmallArray.stdout
new file mode 100644
index 0000000000..86ad8a276c
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CopySmallArray.stdout
@@ -0,0 +1,24 @@
+[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1]
+
+[-1,1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384,-1]
+
+[0,169,196,9,16,25,36,25,36,16,25,81,100,121,144]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256,289,324,361,400,441,484,529,576,625,676,729,784,841,900,961,1024,1089,1156,1225,1296,1369,1444,1521,1600,1681,1764,1849,1936,2025,2116,2209,2304,2401,2500,2601,2704,2809,2916,3025,3136,3249,3364,3481,3600,3721,3844,3969,4096,4225,4356,4489,4624,4761,4900,5041,5184,5329,5476,5625,5776,5929,6084,6241,6400,6561,6724,6889,7056,7225,7396,7569,7744,7921,8100,8281,8464,8649,8836,9025,9216,9409,9604,9801,10000,10201,10404,10609,10816,11025,11236,11449,11664,11881,12100,12321,12544,12769,12996,13225,13456,13689,13924,14161,14400,14641,14884,15129,15376,15625,15876,16129,16384]
+
+[1,4,9,16,25,36,49,64,81,100,121,144,169,196,225,256]
+
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs
new file mode 100644
index 0000000000..7243fadb06
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.hs
@@ -0,0 +1,387 @@
+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
+ UnboxedTuples #-}
+
+-- !!! stress tests of copying/cloning primitive arrays
+
+-- Note: You can run this test manually with an argument (i.e.
+-- ./CopySmallArrayStressTest 10000) if you want to run the stress
+-- test for longer.
+
+{-
+Test strategy
+=============
+
+We create an array of arrays of integers. Repeatedly we then either
+
+* allocate a new array in place of an old, or
+
+* copy a random segment of an array into another array (which might be
+ the source array).
+
+By running this process long enough we hope to trigger any bugs
+related to garbage collection or edge cases.
+
+We only test copySmallMutableArray# and cloneSmallArray# as they are
+representative of all the primops.
+-}
+
+module Main ( main ) where
+
+import Debug.Trace (trace)
+
+import Control.Exception (assert)
+import Control.Monad
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Class
+import GHC.Exts hiding (IsList(..))
+import GHC.ST hiding (liftST)
+import Prelude hiding (length, read)
+import qualified Prelude as P
+import qualified Prelude as P
+import System.Environment
+import System.Random
+
+main :: IO ()
+main = do
+ args <- getArgs
+ -- Number of copies to perform
+ let numMods = case args of
+ [] -> 100
+ [n] -> P.read n :: Int
+ putStr (test_copyMutableArray numMods ++ "\n" ++
+ test_cloneMutableArray numMods ++ "\n"
+ )
+
+-- Number of arrays
+numArrays :: Int
+numArrays = 100
+
+-- Maxmimum length of a sub-array
+maxLen :: Int
+maxLen = 1024
+
+-- Create an array of arrays, with each sub-array having random length
+-- and content.
+setup :: Rng s (MArray s (MArray s Int))
+setup = do
+ len <- rnd (1, numArrays)
+ marr <- liftST $ new_ len
+ let go i
+ | i >= len = return ()
+ | otherwise = do
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr i subarr
+ go (i+1)
+ go 0
+ return marr
+
+-- Replace one of the sub-arrays with a newly allocated array.
+allocate :: MArray s (MArray s Int) -> Rng s ()
+allocate marr = do
+ ix <- rnd (0, length marr - 1)
+ n <- rnd (1, maxLen)
+ subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
+ liftST $ write marr ix subarr
+
+type CopyFunction s a =
+ MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+
+-- Copy a random segment of an array onto another array, using the
+-- supplied copy function.
+copy :: MArray s (MArray s a) -> CopyFunction s a
+ -> Rng s (Int, Int, Int, Int, Int)
+copy marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ dst <- liftST $ read marr dix
+ let srcLen = length src
+ srcOff <- rnd (0, srcLen - 1)
+ let dstLen = length dst
+ dstOff <- rnd (0, dstLen - 1)
+ n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
+ liftST $ f src srcOff dst dstOff n
+ return (six, dix, srcOff, dstOff, n)
+
+type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)
+
+-- Clone a random segment of an array, replacing another array, using
+-- the supplied clone function.
+clone :: MArray s (MArray s a) -> CloneFunction s a
+ -> Rng s (Int, Int, Int, Int)
+clone marr f = do
+ six <- rnd (0, length marr - 1)
+ dix <- rnd (0, length marr - 1)
+ src <- liftST $ read marr six
+ let srcLen = length src
+ -- N.B. The array length might be zero if we previously cloned
+ -- zero elements from some array.
+ srcOff <- rnd (0, max 0 (srcLen - 1))
+ n <- rnd (0, srcLen - srcOff)
+ dst <- liftST $ f src srcOff n
+ liftST $ write marr dix dst
+ return (six, dix, srcOff, n)
+
+------------------------------------------------------------------------
+-- copySmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_copyMutableArray :: Int -> String
+test_copyMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_copyMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or copy
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doCopy
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doCopy = do
+ inp <- liftST $ asList marr
+ _ <- local $ copy marr copyMArray
+ (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff dstOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff dstOff n =
+ error $ "test_copyMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+asList :: MArray s (MArray s a) -> ST s [[a]]
+asList marr = toListM =<< mapArrayM toListM marr
+
+unlinesShow :: Show a => [a] -> String
+unlinesShow = concatMap (\ x -> show x ++ "\n")
+
+------------------------------------------------------------------------
+-- cloneSmallMutableArray#
+
+-- Copy a slice of the source array into a destination array and check
+-- that the copy succeeded.
+test_cloneMutableArray :: Int -> String
+test_cloneMutableArray numMods = runST $ run $ do
+ marr <- local setup
+ marrRef <- setup
+ let go i
+ | i >= numMods = return "test_cloneMutableArray: OK"
+ | otherwise = do
+ -- Either allocate or clone
+ alloc <- rnd (True, False)
+ if alloc then doAlloc else doClone
+ go (i+1)
+
+ doAlloc = do
+ local $ allocate marr
+ allocate marrRef
+
+ doClone = do
+ inp <- liftST $ asList marr
+ _ <- local $ clone marr cloneMArray
+ (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
+ el <- liftST $ asList marr
+ elRef <- liftST $ asList marrRef
+ when (el /= elRef) $
+ fail inp el elRef six dix srcOff n
+ go 0
+ where
+ fail inp el elRef six dix srcOff n =
+ error $ "test_cloneMutableArray: FAIL\n"
+ ++ " Input: " ++ unlinesShow inp
+ ++ " Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
+ ++ show srcOff ++ " n: " ++ show n ++ "\n"
+ ++ "Expected: " ++ unlinesShow elRef
+ ++ " Actual: " ++ unlinesShow el
+
+------------------------------------------------------------------------
+-- Convenience wrappers for SmallArray# and SmallMutableArray#
+
+data Array a = Array
+ { unArray :: SmallArray# a
+ , lengthA :: {-# UNPACK #-} !Int}
+
+data MArray s a = MArray
+ { unMArray :: SmallMutableArray# s a
+ , lengthM :: {-# UNPACK #-} !Int}
+
+class IArray a where
+ length :: a -> Int
+instance IArray (Array a) where
+ length = lengthA
+instance IArray (MArray s a) where
+ length = lengthM
+
+instance Eq a => Eq (Array a) where
+ arr1 == arr2 = toList arr1 == toList arr2
+
+new :: Int -> a -> ST s (MArray s a)
+new n@(I# n#) a =
+ assert (n >= 0) $
+ ST $ \s# -> case newSmallArray# n# a s# of
+ (# s2#, marr# #) -> (# s2#, MArray marr# n #)
+
+new_ :: Int -> ST s (MArray s a)
+new_ n = new n (error "Undefined element")
+
+write :: MArray s a -> Int -> a -> ST s ()
+write marr i@(I# i#) a =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ case writeSmallArray# (unMArray marr) i# a s# of
+ s2# -> (# s2#, () #)
+
+read :: MArray s a -> Int -> ST s a
+read marr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length marr) $
+ ST $ \ s# ->
+ readSmallArray# (unMArray marr) i# s#
+
+index :: Array a -> Int -> a
+index arr i@(I# i#) =
+ assert (i >= 0) $
+ assert (i < length arr) $
+ case indexSmallArray# (unArray arr) i# of
+ (# a #) -> a
+
+unsafeFreeze :: MArray s a -> ST s (Array a)
+unsafeFreeze marr = ST $ \ s# ->
+ case unsafeFreezeSmallArray# (unMArray marr) s# of
+ (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)
+
+toList :: Array a -> [a]
+toList arr = go 0
+ where
+ go i | i >= length arr = []
+ | otherwise = index arr i : go (i+1)
+
+fromList :: [e] -> ST s (MArray s e)
+fromList es = do
+ marr <- new_ n
+ let go !_ [] = return ()
+ go i (x:xs) = write marr i x >> go (i+1) xs
+ go 0 es
+ return marr
+ where
+ n = P.length es
+
+mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
+mapArrayM f src = do
+ dst <- new_ n
+ let go i
+ | i >= n = return dst
+ | otherwise = do
+ el <- read src i
+ el' <- f el
+ write dst i el'
+ go (i+1)
+ go 0
+ where
+ n = length src
+
+toListM :: MArray s e -> ST s [e]
+toListM marr =
+ sequence [read marr i | i <- [0..(length marr)-1]]
+
+------------------------------------------------------------------------
+-- Wrappers around copy/clone primops
+
+copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
+copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ ST $ \ s# ->
+ case copySmallMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
+ s2# -> (# s2#, () #)
+
+cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArray marr off@(I# off#) n@(I# n#) =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $
+ ST $ \ s# ->
+ case cloneSmallMutableArray# (unMArray marr) off# n# s# of
+ (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)
+
+------------------------------------------------------------------------
+-- Manual versions of copy/clone primops. Used to validate the
+-- primops
+
+copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
+copyMArraySlow !src !six !dst !dix n =
+ assert (six >= 0) $
+ assert (six + n <= length src) $
+ assert (dix >= 0) $
+ assert (dix + n <= length dst) $
+ if six < dix
+ then goB (six+n-1) (dix+n-1) 0 -- Copy backwards
+ else goF six dix 0 -- Copy forwards
+ where
+ goF !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goF (i+1) (j+1) (c+1)
+ goB !i !j c
+ | c >= n = return ()
+ | otherwise = do b <- read src i
+ write dst j b
+ goB (i-1) (j-1) (c+1)
+
+cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
+cloneMArraySlow !marr !off n =
+ assert (off >= 0) $
+ assert (off + n <= length marr) $ do
+ marr2 <- new_ n
+ let go !i !j c
+ | c >= n = return marr2
+ | otherwise = do
+ b <- read marr i
+ write marr2 j b
+ go (i+1) (j+1) (c+1)
+ go off 0 0
+
+------------------------------------------------------------------------
+-- Utilities for simplifying RNG passing
+
+newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
+ deriving Monad
+
+-- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
+rnd :: Random a => (a, a) -> Rng s a
+rnd r = Rng $ do
+ g <- get
+ let (x, g') = randomR r g
+ put g'
+ return x
+
+-- Run a sub-computation without affecting the RNG state.
+local :: Rng s a -> Rng s a
+local m = Rng $ do
+ g <- get
+ x <- unRng m
+ put g
+ return x
+
+liftST :: ST s a -> Rng s a
+liftST m = Rng $ lift m
+
+run :: Rng s a -> ST s a
+run = flip evalStateT (mkStdGen 13) . unRng
+
diff --git a/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout
new file mode 100644
index 0000000000..122a125a8e
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CopySmallArrayStressTest.stdout
@@ -0,0 +1,2 @@
+test_copyMutableArray: OK
+test_cloneMutableArray: OK
diff --git a/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs
new file mode 100644
index 0000000000..2e62709748
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module Main ( main ) where
+
+import GHC.Exts
+import GHC.Prim
+import GHC.ST
+
+main = putStr
+ (test_sizeofArray
+ ++ "\n" ++ test_sizeofMutableArray
+ ++ "\n"
+ )
+
+test_sizeofArray :: String
+test_sizeofArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
+ where
+ go i@(I# i#) acc s#
+ | i < 1000 = case newSmallArray# i# 0 s# of
+ (# s2#, marr# #) -> case unsafeFreezeSmallArray# marr# s2# of
+ (# s3#, arr# #) -> case sizeofSmallArray# arr# of
+ j# -> go (i+1) ((I# j#):acc) s3#
+ | otherwise = (# s#, reverse acc #)
+
+test_sizeofMutableArray :: String
+test_sizeofMutableArray = flip shows "\n" $ runST $ ST $ \ s# -> go 0 [] s#
+ where
+ go i@(I# i#) acc s#
+ | i < 1000 = case newSmallArray# i# 0 s# of
+ (# s2#, marr# #) -> case sizeofSmallMutableArray# marr# of
+ j# -> go (i+1) ((I# j#):acc) s2#
+ | otherwise = (# s#, reverse acc #)
diff --git a/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout
new file mode 100644
index 0000000000..bf895d50ef
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/SizeOfSmallArray.stdout
@@ -0,0 +1,4 @@
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+
+[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999]
+
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index bfe393d129..7604427a00 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -118,3 +118,6 @@ test('T8256', reqlib('vector'), compile_and_run, [''])
test('T6084',normal, compile_and_run, ['-O2'])
test('StaticArraySize', normal, compile_and_run, ['-O2'])
test('StaticByteArraySize', normal, compile_and_run, ['-O2'])
+test('CopySmallArray', normal, compile_and_run, [''])
+test('CopySmallArrayStressTest', normal, compile_and_run, [''])
+test('SizeOfSmallArray', normal, compile_and_run, [''])