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
|
{-# LANGUAGE ScopedTypeVariables #-}
module Tests.Vector.UnitTests (tests) where
import Control.Applicative as Applicative
import Control.Exception
import Control.Monad.Primitive
import Control.Monad.Fix (mfix)
import Data.Int
import Data.Word
import Data.Typeable
import qualified Data.List as List
import qualified Data.Vector.Generic as Generic
import qualified Data.Vector as Boxed
import qualified Data.Vector.Internal.Check as Check
import qualified Data.Vector.Mutable as MBoxed
import qualified Data.Vector.Primitive as Primitive
import qualified Data.Vector.Storable as Storable
import qualified Data.Vector.Unboxed as Unboxed
import Foreign.Ptr
import Foreign.Storable
import Text.Printf
import Test.Tasty
import Test.Tasty.HUnit (testCase, Assertion, assertBool, assertEqual, (@=?), assertFailure)
newtype Aligned a = Aligned { getAligned :: a }
instance (Storable a) => Storable (Aligned a) where
sizeOf _ = sizeOf (undefined :: a)
alignment _ = 128
peek ptr = Aligned Applicative.<$> peek (castPtr ptr)
poke ptr = poke (castPtr ptr) . getAligned
checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion
checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do
let ptr' = ptrToWordPtr ptr
msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr')
align :: WordPtr
align = fromIntegral $ alignment dummy
assertBool msg $ (ptr' `mod` align) == 0
where
dummy :: a
dummy = undefined
withBoundsChecksOnly :: [TestTree] -> [TestTree]
withBoundsChecksOnly ts =
if Check.doChecks Check.Bounds
then ts
else []
tests :: [TestTree]
tests =
[ testGroup "Data.Vector.Storable.Vector Alignment"
[ testCase "Aligned Double" $
checkAddressAlignment alignedDoubleVec
, testCase "Aligned Int" $
checkAddressAlignment alignedIntVec
]
, testGroup "Regression tests"
[ testGroup "enumFromTo crash #188"
[ regression188 ([] :: [Word8])
, regression188 ([] :: [Word16])
, regression188 ([] :: [Word32])
, regression188 ([] :: [Word64])
, regression188 ([] :: [Word])
, regression188 ([] :: [Int8])
, regression188 ([] :: [Int16])
, regression188 ([] :: [Int32])
, regression188 ([] :: [Int64])
, regression188 ([] :: [Int])
, regression188 ([] :: [Char])
]
]
, testGroup "Negative tests" $
withBoundsChecksOnly [ testGroup "slice out of bounds #257"
[ testGroup "Boxed" $ testsSliceOutOfBounds Boxed.slice
, testGroup "Primitive" $ testsSliceOutOfBounds Primitive.slice
, testGroup "Storable" $ testsSliceOutOfBounds Storable.slice
, testGroup "Unboxed" $ testsSliceOutOfBounds Unboxed.slice
]]
++
[ testGroup "take #282"
[ testCase "Boxed" $ testTakeOutOfMemory Boxed.take
, testCase "Primitive" $ testTakeOutOfMemory Primitive.take
, testCase "Storable" $ testTakeOutOfMemory Storable.take
, testCase "Unboxed" $ testTakeOutOfMemory Unboxed.take
]
]
, testGroup "Data.Vector"
[ testCase "MonadFix" checkMonadFix
, testCase "toFromArray" toFromArray
, testCase "toFromArraySlice" toFromArraySlice
, testCase "toFromArraySliceUnsafe" toFromArraySliceUnsafe
, testCase "toFromMutableArray" toFromMutableArray
]
]
testsSliceOutOfBounds ::
(Show (v Int), Generic.Vector v Int) => (Int -> Int -> v Int -> v Int) -> [TestTree]
testsSliceOutOfBounds sliceWith =
[ testCase "Negative ix" $ sliceTest sliceWith (-2) 2 xs
, testCase "Negative size" $ sliceTest sliceWith 2 (-2) xs
, testCase "Negative ix and size" $ sliceTest sliceWith (-2) (-1) xs
, testCase "Too large ix" $ sliceTest sliceWith 6 2 xs
, testCase "Too large size" $ sliceTest sliceWith 2 6 xs
, testCase "Too large ix and size" $ sliceTest sliceWith 6 6 xs
, testCase "Overflow" $ sliceTest sliceWith 1 maxBound xs
, testCase "OutOfMemory" $ sliceTest sliceWith 1 (maxBound `div` intSize) xs
]
where
intSize = sizeOf (undefined :: Int)
xs = [1, 2, 3, 4, 5] :: [Int]
{-# INLINE testsSliceOutOfBounds #-}
sliceTest ::
(Show (v Int), Generic.Vector v Int)
=> (Int -> Int -> v Int -> v Int)
-> Int
-> Int
-> [Int]
-> Assertion
sliceTest sliceWith i m xs = do
let vec = Generic.fromList xs
eRes <- try (pure $! sliceWith i m vec)
case eRes of
Right v ->
assertFailure $
"Data.Vector.Internal.Check.checkSlice failed to check: " ++ show v
Left (ErrorCall err) ->
let assertMsg =
List.concat
[ "Expected slice function to produce an 'error' ending with: \""
, errSuffix
, "\" instead got: \""
, err
]
in assertBool assertMsg (errSuffix `List.isSuffixOf` err)
where
errSuffix =
"invalid slice (" ++
show i ++ "," ++ show m ++ "," ++ show (List.length xs) ++ ")"
{-# INLINE sliceTest #-}
testTakeOutOfMemory ::
(Show (v Int), Eq (v Int), Generic.Vector v Int) => (Int -> v Int -> v Int) -> Assertion
testTakeOutOfMemory takeWith =
takeWith (maxBound `div` intSize) (Generic.fromList xs) @=? Generic.fromList xs
where
intSize = sizeOf (undefined :: Int)
xs = [1, 2, 3, 4, 5] :: [Int]
{-# INLINE testTakeOutOfMemory #-}
regression188
:: forall proxy a. (Typeable a, Enum a, Bounded a, Eq a, Show a)
=> proxy a -> TestTree
regression188 _ = testCase (show (typeOf (undefined :: a)))
$ Boxed.fromList [maxBound::a] @=? Boxed.enumFromTo maxBound maxBound
{-# INLINE regression188 #-}
alignedDoubleVec :: Storable.Vector (Aligned Double)
alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]
alignedIntVec :: Storable.Vector (Aligned Int)
alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5]
-- Ensure that Mutable is really an injective type family by typechecking a
-- function which relies on injectivity.
_f :: (Generic.Vector v a, Generic.Vector w a, PrimMonad f)
=> Generic.Mutable v (PrimState f) a -> f (w a)
_f v = Generic.convert `fmap` Generic.unsafeFreeze v
checkMonadFix :: Assertion
checkMonadFix = assertBool "checkMonadFix" $
Boxed.toList fewV == fewL &&
Boxed.toList none == []
where
facty _ 0 = 1; facty f n = n * f (n - 1)
fewV :: Boxed.Vector Int
fewV = fmap ($ 12) $ mfix (\i -> Boxed.fromList [facty i, facty (+1), facty (+2)])
fewL :: [Int]
fewL = fmap ($ 12) $ mfix (\i -> [facty i, facty (+1), facty (+2)])
none :: Boxed.Vector Int
none = mfix (const Boxed.empty)
mkArrayRoundtrip :: (String -> Boxed.Vector Integer -> Assertion) -> Assertion
mkArrayRoundtrip mkAssertion =
sequence_
[ mkAssertion name v
| (name, v) <-
[ ("full", vec)
, ("slicedTail", Boxed.slice 0 (n - 3) vec)
, ("slicedHead", Boxed.slice 2 (n - 2) vec)
, ("slicedBoth", Boxed.slice 2 (n - 4) vec)
]
]
where
vec = Boxed.fromList [0 .. 10]
n = Boxed.length vec
toFromArray :: Assertion
toFromArray =
mkArrayRoundtrip $ \name v ->
assertEqual name v $ Boxed.fromArray (Boxed.toArray v)
toFromArraySlice :: Assertion
toFromArraySlice =
mkArrayRoundtrip $ \name v ->
case Boxed.toArraySlice v of
(arr, off, n) ->
assertEqual name v $
Boxed.take n (Boxed.drop off (Boxed.fromArray arr))
toFromArraySliceUnsafe :: Assertion
toFromArraySliceUnsafe =
mkArrayRoundtrip $ \name v ->
case Boxed.toArraySlice v of
(arr, off, n) ->
assertEqual name v $
Boxed.unsafeFromArraySlice arr off n
toFromMutableArray :: Assertion
toFromMutableArray = mkArrayRoundtrip assetRoundtrip
where
assetRoundtrip assertionName vec = do
mvec <- Boxed.unsafeThaw vec
mvec' <- MBoxed.fromMutableArray =<< MBoxed.toMutableArray mvec
vec' <- Boxed.unsafeFreeze mvec'
assertEqual assertionName vec vec'
|
