Error message wibbles when adding overloaded lists
[ghc.git] / testsuite / tests / codeGen / should_run / cgrun068.hs
1 {-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, MagicHash,
2 UnboxedTuples #-}
3
4 -- !!! stress tests of copying/cloning primitive arrays
5
6 -- Note: You can run this test manually with an argument
7 -- (i.e. ./cgrun068 10000) if you want to run the stress test for
8 -- longer.
9
10 {-
11 Test strategy
12 =============
13
14 We create an array of arrays of integers. Repeatedly we then either
15
16 * allocate a new array in place of an old, or
17
18 * copy a random segment of an array into another array (which might be
19 the source array).
20
21 By running this process long enough we hope to trigger any bugs
22 related to garbage collection or edge cases.
23
24 We only test copyMutableArray# and cloneArray# as they are
25 representative of all the primops.
26 -}
27
28 module Main ( main ) where
29
30 import Debug.Trace (trace)
31
32 import Control.Exception (assert)
33 import Control.Monad
34 import Control.Monad.Trans.State.Strict
35 import Control.Monad.Trans.Class
36 import GHC.Exts hiding (IsList(..))
37 import GHC.ST hiding (liftST)
38 import Prelude hiding (length, read)
39 import qualified Prelude as P
40 import qualified Prelude as P
41 import System.Environment
42 import System.Random
43
44 main :: IO ()
45 main = do
46 args <- getArgs
47 -- Number of copies to perform
48 let numMods = case args of
49 [] -> 100
50 [n] -> P.read n :: Int
51 putStr (test_copyMutableArray numMods ++ "\n" ++
52 test_cloneMutableArray numMods ++ "\n"
53 )
54
55 -- Number of arrays
56 numArrays :: Int
57 numArrays = 100
58
59 -- Maxmimum length of a sub-array
60 maxLen :: Int
61 maxLen = 1024
62
63 -- Create an array of arrays, with each sub-array having random length
64 -- and content.
65 setup :: Rng s (MArray s (MArray s Int))
66 setup = do
67 len <- rnd (1, numArrays)
68 marr <- liftST $ new_ len
69 let go i
70 | i >= len = return ()
71 | otherwise = do
72 n <- rnd (1, maxLen)
73 subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
74 liftST $ write marr i subarr
75 go (i+1)
76 go 0
77 return marr
78
79 -- Replace one of the sub-arrays with a newly allocated array.
80 allocate :: MArray s (MArray s Int) -> Rng s ()
81 allocate marr = do
82 ix <- rnd (0, length marr - 1)
83 n <- rnd (1, maxLen)
84 subarr <- liftST $ fromList [j*j | j <- [(0::Int)..n-1]]
85 liftST $ write marr ix subarr
86
87 type CopyFunction s a =
88 MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
89
90 -- Copy a random segment of an array onto another array, using the
91 -- supplied copy function.
92 copy :: MArray s (MArray s a) -> CopyFunction s a
93 -> Rng s (Int, Int, Int, Int, Int)
94 copy marr f = do
95 six <- rnd (0, length marr - 1)
96 dix <- rnd (0, length marr - 1)
97 src <- liftST $ read marr six
98 dst <- liftST $ read marr dix
99 let srcLen = length src
100 srcOff <- rnd (0, srcLen - 1)
101 let dstLen = length dst
102 dstOff <- rnd (0, dstLen - 1)
103 n <- rnd (0, min (srcLen - srcOff) (dstLen - dstOff))
104 liftST $ f src srcOff dst dstOff n
105 return (six, dix, srcOff, dstOff, n)
106
107 type CloneFunction s a = MArray s a -> Int -> Int -> ST s (MArray s a)
108
109 -- Clone a random segment of an array, replacing another array, using
110 -- the supplied clone function.
111 clone :: MArray s (MArray s a) -> CloneFunction s a
112 -> Rng s (Int, Int, Int, Int)
113 clone marr f = do
114 six <- rnd (0, length marr - 1)
115 dix <- rnd (0, length marr - 1)
116 src <- liftST $ read marr six
117 let srcLen = length src
118 -- N.B. The array length might be zero if we previously cloned
119 -- zero elements from some array.
120 srcOff <- rnd (0, max 0 (srcLen - 1))
121 n <- rnd (0, srcLen - srcOff)
122 dst <- liftST $ f src srcOff n
123 liftST $ write marr dix dst
124 return (six, dix, srcOff, n)
125
126 ------------------------------------------------------------------------
127 -- copyMutableArray#
128
129 -- Copy a slice of the source array into a destination array and check
130 -- that the copy succeeded.
131 test_copyMutableArray :: Int -> String
132 test_copyMutableArray numMods = runST $ run $ do
133 marr <- local setup
134 marrRef <- setup
135 let go i
136 | i >= numMods = return "test_copyMutableArray: OK"
137 | otherwise = do
138 -- Either allocate or copy
139 alloc <- rnd (True, False)
140 if alloc then doAlloc else doCopy
141 go (i+1)
142
143 doAlloc = do
144 local $ allocate marr
145 allocate marrRef
146
147 doCopy = do
148 inp <- liftST $ asList marr
149 _ <- local $ copy marr copyMArray
150 (six, dix, srcOff, dstOff, n) <- copy marrRef copyMArraySlow
151 el <- liftST $ asList marr
152 elRef <- liftST $ asList marrRef
153 when (el /= elRef) $
154 fail inp el elRef six dix srcOff dstOff n
155 go 0
156 where
157 fail inp el elRef six dix srcOff dstOff n =
158 error $ "test_copyMutableArray: FAIL\n"
159 ++ " Input: " ++ unlinesShow inp
160 ++ " Copy: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
161 ++ show srcOff ++ " dstOff: " ++ show dstOff ++ " n: " ++ show n ++ "\n"
162 ++ "Expected: " ++ unlinesShow elRef
163 ++ " Actual: " ++ unlinesShow el
164
165 asList :: MArray s (MArray s a) -> ST s [[a]]
166 asList marr = toListM =<< mapArrayM toListM marr
167
168 unlinesShow :: Show a => [a] -> String
169 unlinesShow = concatMap (\ x -> show x ++ "\n")
170
171 ------------------------------------------------------------------------
172 -- cloneMutableArray#
173
174 -- Copy a slice of the source array into a destination array and check
175 -- that the copy succeeded.
176 test_cloneMutableArray :: Int -> String
177 test_cloneMutableArray numMods = runST $ run $ do
178 marr <- local setup
179 marrRef <- setup
180 let go i
181 | i >= numMods = return "test_cloneMutableArray: OK"
182 | otherwise = do
183 -- Either allocate or clone
184 alloc <- rnd (True, False)
185 if alloc then doAlloc else doClone
186 go (i+1)
187
188 doAlloc = do
189 local $ allocate marr
190 allocate marrRef
191
192 doClone = do
193 inp <- liftST $ asList marr
194 _ <- local $ clone marr cloneMArray
195 (six, dix, srcOff, n) <- clone marrRef cloneMArraySlow
196 el <- liftST $ asList marr
197 elRef <- liftST $ asList marrRef
198 when (el /= elRef) $
199 fail inp el elRef six dix srcOff n
200 go 0
201 where
202 fail inp el elRef six dix srcOff n =
203 error $ "test_cloneMutableArray: FAIL\n"
204 ++ " Input: " ++ unlinesShow inp
205 ++ " Clone: six: " ++ show six ++ " dix: " ++ show dix ++ " srcOff: "
206 ++ show srcOff ++ " n: " ++ show n ++ "\n"
207 ++ "Expected: " ++ unlinesShow elRef
208 ++ " Actual: " ++ unlinesShow el
209
210 ------------------------------------------------------------------------
211 -- Convenience wrappers for Array# and MutableArray#
212
213 data Array a = Array
214 { unArray :: Array# a
215 , lengthA :: {-# UNPACK #-} !Int}
216
217 data MArray s a = MArray
218 { unMArray :: MutableArray# s a
219 , lengthM :: {-# UNPACK #-} !Int}
220
221 class IArray a where
222 length :: a -> Int
223 instance IArray (Array a) where
224 length = lengthA
225 instance IArray (MArray s a) where
226 length = lengthM
227
228 instance Eq a => Eq (Array a) where
229 arr1 == arr2 = toList arr1 == toList arr2
230
231 new :: Int -> a -> ST s (MArray s a)
232 new n@(I# n#) a =
233 assert (n >= 0) $
234 ST $ \s# -> case newArray# n# a s# of
235 (# s2#, marr# #) -> (# s2#, MArray marr# n #)
236
237 new_ :: Int -> ST s (MArray s a)
238 new_ n = new n (error "Undefined element")
239
240 write :: MArray s a -> Int -> a -> ST s ()
241 write marr i@(I# i#) a =
242 assert (i >= 0) $
243 assert (i < length marr) $
244 ST $ \ s# ->
245 case writeArray# (unMArray marr) i# a s# of
246 s2# -> (# s2#, () #)
247
248 read :: MArray s a -> Int -> ST s a
249 read marr i@(I# i#) =
250 assert (i >= 0) $
251 assert (i < length marr) $
252 ST $ \ s# ->
253 readArray# (unMArray marr) i# s#
254
255 index :: Array a -> Int -> a
256 index arr i@(I# i#) =
257 assert (i >= 0) $
258 assert (i < length arr) $
259 case indexArray# (unArray arr) i# of
260 (# a #) -> a
261
262 unsafeFreeze :: MArray s a -> ST s (Array a)
263 unsafeFreeze marr = ST $ \ s# ->
264 case unsafeFreezeArray# (unMArray marr) s# of
265 (# s2#, arr# #) -> (# s2#, Array arr# (length marr) #)
266
267 toList :: Array a -> [a]
268 toList arr = go 0
269 where
270 go i | i >= length arr = []
271 | otherwise = index arr i : go (i+1)
272
273 fromList :: [e] -> ST s (MArray s e)
274 fromList es = do
275 marr <- new_ n
276 let go !_ [] = return ()
277 go i (x:xs) = write marr i x >> go (i+1) xs
278 go 0 es
279 return marr
280 where
281 n = P.length es
282
283 mapArrayM :: (a -> ST s b) -> MArray s a -> ST s (MArray s b)
284 mapArrayM f src = do
285 dst <- new_ n
286 let go i
287 | i >= n = return dst
288 | otherwise = do
289 el <- read src i
290 el' <- f el
291 write dst i el'
292 go (i+1)
293 go 0
294 where
295 n = length src
296
297 toListM :: MArray s e -> ST s [e]
298 toListM marr =
299 sequence [read marr i | i <- [0..(length marr)-1]]
300
301 ------------------------------------------------------------------------
302 -- Wrappers around copy/clone primops
303
304 copyMArray :: MArray s a -> Int -> MArray s a -> Int -> Int -> ST s ()
305 copyMArray src six@(I# six#) dst dix@(I# dix#) n@(I# n#) =
306 assert (six >= 0) $
307 assert (six + n <= length src) $
308 assert (dix >= 0) $
309 assert (dix + n <= length dst) $
310 ST $ \ s# ->
311 case copyMutableArray# (unMArray src) six# (unMArray dst) dix# n# s# of
312 s2# -> (# s2#, () #)
313
314 cloneMArray :: MArray s a -> Int -> Int -> ST s (MArray s a)
315 cloneMArray marr off@(I# off#) n@(I# n#) =
316 assert (off >= 0) $
317 assert (off + n <= length marr) $
318 ST $ \ s# ->
319 case cloneMutableArray# (unMArray marr) off# n# s# of
320 (# s2#, marr2 #) -> (# s2#, MArray marr2 n #)
321
322 ------------------------------------------------------------------------
323 -- Manual versions of copy/clone primops. Used to validate the
324 -- primops
325
326 copyMArraySlow :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()
327 copyMArraySlow !src !six !dst !dix n =
328 assert (six >= 0) $
329 assert (six + n <= length src) $
330 assert (dix >= 0) $
331 assert (dix + n <= length dst) $
332 if six < dix
333 then goB (six+n-1) (dix+n-1) 0 -- Copy backwards
334 else goF six dix 0 -- Copy forwards
335 where
336 goF !i !j c
337 | c >= n = return ()
338 | otherwise = do b <- read src i
339 write dst j b
340 goF (i+1) (j+1) (c+1)
341 goB !i !j c
342 | c >= n = return ()
343 | otherwise = do b <- read src i
344 write dst j b
345 goB (i-1) (j-1) (c+1)
346
347 cloneMArraySlow :: MArray s a -> Int -> Int -> ST s (MArray s a)
348 cloneMArraySlow !marr !off n =
349 assert (off >= 0) $
350 assert (off + n <= length marr) $ do
351 marr2 <- new_ n
352 let go !i !j c
353 | c >= n = return marr2
354 | otherwise = do
355 b <- read marr i
356 write marr2 j b
357 go (i+1) (j+1) (c+1)
358 go off 0 0
359
360 ------------------------------------------------------------------------
361 -- Utilities for simplifying RNG passing
362
363 newtype Rng s a = Rng { unRng :: StateT StdGen (ST s) a }
364 deriving Monad
365
366 -- Same as 'randomR', but using the RNG state kept in the 'Rng' monad.
367 rnd :: Random a => (a, a) -> Rng s a
368 rnd r = Rng $ do
369 g <- get
370 let (x, g') = randomR r g
371 put g'
372 return x
373
374 -- Run a sub-computation without affecting the RNG state.
375 local :: Rng s a -> Rng s a
376 local m = Rng $ do
377 g <- get
378 x <- unRng m
379 put g
380 return x
381
382 liftST :: ST s a -> Rng s a
383 liftST m = Rng $ lift m
384
385 run :: Rng s a -> ST s a
386 run = flip evalStateT (mkStdGen 13) . unRng
387