diff options
author | Johan Tibell <johan.tibell@gmail.com> | 2014-03-23 12:06:56 +0100 |
---|---|---|
committer | Johan Tibell <johan.tibell@gmail.com> | 2014-03-29 11:24:07 +0100 |
commit | 90329b6cc183b3cd05956ae6bdeb6ac6951549c2 (patch) | |
tree | ba7d31656fe75fad2555c8a66b7ebd13dd9ebeb1 /testsuite/tests/codeGen | |
parent | 4c8edfd2c722504baaa6896d194fd3a8c3f9b652 (diff) | |
download | haskell-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')
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, ['']) |