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
|
-- Code reused from http://hackage.haskell.org/package/deepseq-generics
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
module Main (main) where
import Control.Concurrent.MVar
-- IUT
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Bits
import Data.IORef
import Data.Typeable
import Data.Word
import GHC.Generics
import System.Exit (exitFailure)
import System.IO.Unsafe (unsafePerformIO)
----------------------------------------------------------------------------
-- simple hacky abstraction for testing forced evaluation via `rnf`-like functions
seqStateLock :: MVar ()
seqStateLock = unsafePerformIO $ newMVar ()
{-# NOINLINE seqStateLock #-}
withSeqState :: Word64 -> IO () -> IO ()
withSeqState expectedState act = withMVar seqStateLock $ \() -> do
0 <- resetSeqState
() <- act
st <- resetSeqState
unless (st == expectedState) $ do
putStrLn $
"withSeqState: actual seq-state ("
++ show st
++ ") doesn't match expected value ("
++ show expectedState
++ ")"
exitFailure
seqState :: IORef Word64
seqState = unsafePerformIO $ newIORef 0
{-# NOINLINE seqState #-}
resetSeqState :: IO Word64
resetSeqState = atomicModifyIORef' seqState (0,)
-- | Set flag and raise exception is flag already set
setSeqState :: Int -> IO ()
setSeqState i
| 0 <= i && i < 64 = atomicModifyIORef' seqState go
| otherwise = error "seqSeqState: flag index must be in [0..63]"
where
go x
| testBit x i = error ("setSeqState: flag #" ++ show i ++ " already set")
| otherwise = (setBit x i, ())
-- weird type whose NFData instance calls 'setSeqState' when rnf-ed
data SeqSet = SeqSet !Int | SeqIgnore
deriving (Show)
instance NFData SeqSet where
rnf (SeqSet i) = unsafePerformIO $ setSeqState i
rnf (SeqIgnore) = ()
{-# NOINLINE rnf #-}
-- | Exception to be thrown for testing 'seq'/'rnf'
data RnfEx = RnfEx deriving (Eq, Show, Typeable)
instance Exception RnfEx
instance NFData RnfEx where rnf e = throw e
assertRnfEx :: () -> IO ()
assertRnfEx v = handleJust isWanted (const $ return ()) $ do
() <- evaluate v
putStrLn "failed to trigger expected RnfEx exception"
exitFailure
where
isWanted = guard . (== RnfEx)
----------------------------------------------------------------------------
testCase :: String -> IO a -> IO a
testCase testName io = do
putStrLn testName
io
case_1, case_2, case_3 :: IO ()
case_4_1, case_4_2, case_4_3, case_4_4 :: IO ()
case_4_1b, case_4_2b, case_4_3b, case_4_4b :: IO ()
newtype Case1 = Case1 Int
deriving (Generic)
instance NFData Case1
case_1 = testCase "Case1" $ do
assertRnfEx $ rnf $ (Case1 (throw RnfEx))
----
data Case2 = Case2 Int
deriving (Generic)
instance NFData Case2
case_2 = testCase "Case2" $ do
assertRnfEx $ rnf $ (Case2 (throw RnfEx))
----
data Case3 = Case3 RnfEx
deriving (Generic)
instance NFData Case3
case_3 = testCase "Case3" $ do
assertRnfEx $ rnf $ Case3 RnfEx
----
data Case4 a
= Case4a
| Case4b a a
| Case4c a (Case4 a)
deriving
( Generic
, Generic1
)
instance NFData a => NFData (Case4 a)
instance NFData1 Case4
case_4_1 = testCase "Case4.1" $ withSeqState 0x0 $ do
evaluate $ rnf $ (Case4a :: Case4 SeqSet)
case_4_2 = testCase "Case4.2" $ withSeqState 0x3 $ do
evaluate $ rnf $ (Case4b (SeqSet 0) (SeqSet 1) :: Case4 SeqSet)
case_4_3 = testCase "Case4.3" $ withSeqState (bit 55) $ do
evaluate $ rnf $ (Case4b SeqIgnore (SeqSet 55) :: Case4 SeqSet)
case_4_4 = testCase "Case4.4" $ withSeqState 0xffffffffffffffff $ do
evaluate $ rnf $ (genCase 63)
where
genCase n
| n > 1 = Case4c (SeqSet n) (genCase (n - 1))
| otherwise = Case4b (SeqSet 0) (SeqSet 1)
case_4_1b = testCase "Case4.1b" $ withSeqState 0x0 $ do
evaluate $ rnf1 $ (Case4a :: Case4 SeqSet)
case_4_2b = testCase "Case4.2b" $ withSeqState 0x3 $ do
evaluate $ rnf1 $ (Case4b (SeqSet 0) (SeqSet 1) :: Case4 SeqSet)
case_4_3b = testCase "Case4.3b" $ withSeqState (bit 55) $ do
evaluate $ rnf1 $ (Case4b SeqIgnore (SeqSet 55) :: Case4 SeqSet)
case_4_4b = testCase "Case4.4b" $ withSeqState 0xffffffffffffffff $ do
evaluate $ rnf1 $ (genCase 63)
where
genCase n
| n > 1 = Case4c (SeqSet n) (genCase (n - 1))
| otherwise = Case4b (SeqSet 0) (SeqSet 1)
----------------------------------------------------------------------------
main :: IO ()
main =
sequence_
[ case_1
, case_2
, case_3
, case_4_1
, case_4_2
, case_4_3
, case_4_4
, case_4_1b
, case_4_2b
, case_4_3b
, case_4_4b
]
|
