Skip to content

Commit ebdccf4

Browse files
cootcoot
committed
io-sim: introduce various test for the masking state
* check that `mask_` and `uninterruptibleMask_` can set masking state * check that `unmask` unmasks the masking state to the right state * check that a forked thread inherits masking state * check that `forkIOWithUnmask` unmask function will restore the masking state to `Unmasked`. * check that catch handler has the right masking state (at least `MaskedInterruptible`). This property is checked for synchronous and asynchronous (blocking and non-blocking) exceptions.
1 parent 80aa1d5 commit ebdccf4

File tree

1 file changed

+292
-0
lines changed

1 file changed

+292
-0
lines changed

‎io-sim/test/Test/IOSim.hs

Lines changed: 292 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,51 @@ tests =
5959
, testProperty "5" unit_catch_5
6060
, testProperty "6" unit_catch_6
6161
]
62+
, testGroup "masking state"
63+
[ testProperty "set (IO)"
64+
$ forall_masking_states unit_set_masking_state_IO
65+
, testProperty "set (IOSim)"
66+
$ forall_masking_states unit_set_masking_state_ST
67+
68+
, testProperty "unmask (IO)"
69+
$ forall_masking_states $ \ms ->
70+
forall_masking_states $ \ms' -> unit_unmask_IO ms ms'
71+
, testProperty "unmask (IOSim)"
72+
$ forall_masking_states $ \ms ->
73+
forall_masking_states $ \ms' -> unit_unmask_ST ms ms'
74+
75+
, testProperty "fork (IO)"
76+
$ forall_masking_states unit_fork_masking_state_IO
77+
, testProperty "fork (IOSim)"
78+
$ forall_masking_states unit_fork_masking_state_ST
79+
80+
, testProperty "fork unmask (IO)"
81+
$ forall_masking_states $ \ms ->
82+
forall_masking_states $ \ms' -> unit_fork_unmask_IO ms ms'
83+
, testProperty "fork unmask (IOSim)"
84+
$ forall_masking_states $ \ms ->
85+
forall_masking_states $ \ms' -> unit_fork_unmask_ST ms ms'
86+
87+
, testProperty "catch (IO)"
88+
$ forall_masking_states unit_catch_throwIO_masking_state_IO
89+
, testProperty "catch (IOSim)"
90+
$ forall_masking_states unit_catch_throwIO_masking_state_ST
91+
92+
, testProperty "catch: throwTo (IO)"
93+
$ forall_masking_states unit_catch_throwTo_masking_state_IO
94+
, testProperty "catch: throwTo (IOSim)"
95+
$ forall_masking_states unit_catch_throwTo_masking_state_ST
96+
97+
, testProperty "catch: throwTo async (IO)"
98+
$ forall_masking_states unit_catch_throwTo_masking_state_async_IO
99+
, testProperty "catch: throwTo async (IOSim)"
100+
$ forall_masking_states unit_catch_throwTo_masking_state_async_ST
101+
102+
, testProperty "catch: throwTo async blocking (IO)"
103+
$ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_IO
104+
, testProperty "catch: throwTo async blocking (IOSim)"
105+
$ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST
106+
]
62107
, testProperty "evaluate unit test" unit_evaluate_0
63108
, testGroup "forkIO unit tests"
64109
[ testProperty "1" unit_fork_1
@@ -887,6 +932,253 @@ prop_timeout_no_deadlock_Sim = runSimOrThrow prop_timeout_no_deadlockM
887932
prop_timeout_no_deadlock_IO :: Property
888933
prop_timeout_no_deadlock_IO = ioProperty prop_timeout_no_deadlockM
889934

935+
936+
--
937+
-- MonadMask properties
938+
--
939+
940+
setMaskingState_ :: MonadMask m => MaskingState -> m a -> m a
941+
setMaskingState_ Unmasked = id
942+
setMaskingState_ MaskedInterruptible = mask_
943+
setMaskingState_ MaskedUninterruptible = uninterruptibleMask_
944+
945+
setMaskingState :: MonadMask m => MaskingState
946+
-> ((forall x. m x -> m x) -> m a) -> m a
947+
setMaskingState Unmasked = \f -> f id
948+
setMaskingState MaskedInterruptible = mask
949+
setMaskingState MaskedUninterruptible = uninterruptibleMask
950+
951+
maxMS :: MaskingState -> MaskingState -> MaskingState
952+
maxMS MaskedUninterruptible _ = MaskedUninterruptible
953+
maxMS _ MaskedUninterruptible = MaskedUninterruptible
954+
maxMS MaskedInterruptible _ = MaskedInterruptible
955+
maxMS _ MaskedInterruptible = MaskedInterruptible
956+
maxMS Unmasked Unmasked = Unmasked
957+
958+
959+
forall_masking_states :: (MaskingState -> Property)
960+
-> Property
961+
forall_masking_states prop =
962+
-- make sure that the property is executed once!
963+
withMaxSuccess 1 $
964+
foldr (\ms p -> counterexample (show ms) (prop ms) .&&. p)
965+
(property True)
966+
[Unmasked, MaskedInterruptible, MaskedUninterruptible]
967+
968+
-- | Check that setting masking state is effective.
969+
--
970+
prop_set_masking_state :: MonadMaskingState m
971+
=> MaskingState
972+
-> m Property
973+
prop_set_masking_state ms =
974+
setMaskingState_ ms $ do
975+
ms' <- getMaskingState
976+
return (ms === ms')
977+
978+
unit_set_masking_state_IO :: MaskingState -> Property
979+
unit_set_masking_state_IO =
980+
ioProperty . prop_set_masking_state
981+
982+
unit_set_masking_state_ST :: MaskingState -> Property
983+
unit_set_masking_state_ST ms =
984+
runSimOrThrow (prop_set_masking_state ms)
985+
986+
987+
-- | Check that 'unmask' restores the masking state.
988+
--
989+
prop_unmask :: MonadMaskingState m
990+
=> MaskingState
991+
-> MaskingState
992+
-> m Property
993+
prop_unmask ms ms' =
994+
setMaskingState_ ms $
995+
setMaskingState ms' $ \unmask -> do
996+
ms'' <- unmask getMaskingState
997+
return (ms'' === ms)
998+
999+
unit_unmask_IO :: MaskingState -> MaskingState -> Property
1000+
unit_unmask_IO ms ms' = ioProperty $ prop_unmask ms ms'
1001+
1002+
unit_unmask_ST :: MaskingState -> MaskingState -> Property
1003+
unit_unmask_ST ms ms' = runSimOrThrow $ prop_unmask ms ms'
1004+
1005+
1006+
-- | Check that masking state is inherited by a forked thread.
1007+
--
1008+
prop_fork_masking_state :: ( MonadMaskingState m
1009+
, MonadFork m
1010+
, MonadSTM m
1011+
)
1012+
=> MaskingState -> m Property
1013+
prop_fork_masking_state ms = setMaskingState_ ms $ do
1014+
var <- newEmptyTMVarIO
1015+
_ <- forkIO $ getMaskingState >>= atomically . putTMVar var
1016+
ms' <- atomically $ takeTMVar var
1017+
return $ ms === ms'
1018+
1019+
unit_fork_masking_state_IO :: MaskingState -> Property
1020+
unit_fork_masking_state_IO =
1021+
ioProperty . prop_fork_masking_state
1022+
1023+
unit_fork_masking_state_ST :: MaskingState -> Property
1024+
unit_fork_masking_state_ST ms =
1025+
runSimOrThrow (prop_fork_masking_state ms)
1026+
1027+
1028+
-- | Check that 'unmask' restores the masking state in a forked thread.
1029+
--
1030+
-- Note: unlike 'prop_unmask', 'forkIOWithUnmask's 'unmask' function will
1031+
-- restore 'Unmasked' state, not the encosing masking state.
1032+
--
1033+
prop_fork_unmask :: ( MonadMaskingState m
1034+
, MonadFork m
1035+
, MonadSTM m
1036+
)
1037+
=> MaskingState
1038+
-> MaskingState
1039+
-> m Property
1040+
prop_fork_unmask ms ms' =
1041+
setMaskingState_ ms $
1042+
setMaskingState_ ms' $ do
1043+
var <- newEmptyTMVarIO
1044+
_ <- forkIOWithUnmask $ \unmask -> unmask getMaskingState
1045+
>>= atomically . putTMVar var
1046+
ms'' <- atomically $ takeTMVar var
1047+
return $ Unmasked === ms''
1048+
1049+
unit_fork_unmask_IO :: MaskingState -> MaskingState -> Property
1050+
unit_fork_unmask_IO ms ms' = ioProperty $ prop_fork_unmask ms ms'
1051+
1052+
unit_fork_unmask_ST :: MaskingState -> MaskingState -> Property
1053+
unit_fork_unmask_ST ms ms' = runSimOrThrow $ prop_fork_unmask ms ms'
1054+
1055+
1056+
-- | A unit test which checks the masking state in the context of a catch
1057+
-- handler.
1058+
--
1059+
prop_catch_throwIO_masking_state :: forall m. MonadMaskingState m
1060+
=> MaskingState -> m Property
1061+
prop_catch_throwIO_masking_state ms =
1062+
setMaskingState_ ms $ do
1063+
throwIO (userError "error")
1064+
`catch` \(_ :: IOError) -> do
1065+
ms' <- getMaskingState
1066+
return $ ms' === MaskedInterruptible `maxMS` ms
1067+
1068+
unit_catch_throwIO_masking_state_IO :: MaskingState -> Property
1069+
unit_catch_throwIO_masking_state_IO ms =
1070+
ioProperty $ prop_catch_throwIO_masking_state ms
1071+
1072+
unit_catch_throwIO_masking_state_ST :: MaskingState -> Property
1073+
unit_catch_throwIO_masking_state_ST ms =
1074+
runSimOrThrow (prop_catch_throwIO_masking_state ms)
1075+
1076+
1077+
-- | Like 'prop_catch_masking_state' but using 'throwTo'.
1078+
--
1079+
prop_catch_throwTo_masking_state :: forall m.
1080+
( MonadMaskingState m
1081+
, MonadFork m
1082+
)
1083+
=> MaskingState -> m Property
1084+
prop_catch_throwTo_masking_state ms =
1085+
setMaskingState_ ms $ do
1086+
tid <- myThreadId
1087+
(throwTo tid (userError "error") >> error "impossible")
1088+
`catch` \(_ :: IOError) -> do
1089+
ms' <- getMaskingState
1090+
return $ ms' === MaskedInterruptible `maxMS` ms
1091+
1092+
unit_catch_throwTo_masking_state_IO :: MaskingState -> Property
1093+
unit_catch_throwTo_masking_state_IO =
1094+
ioProperty . prop_catch_throwTo_masking_state
1095+
1096+
unit_catch_throwTo_masking_state_ST :: MaskingState -> Property
1097+
unit_catch_throwTo_masking_state_ST ms =
1098+
runSimOrThrow $ prop_catch_throwTo_masking_state ms
1099+
1100+
1101+
-- | Like 'prop_catch_throwTo_masking_state' but using 'throwTo' to a different
1102+
-- thread which is in a non-blocking mode.
1103+
--
1104+
prop_catch_throwTo_masking_state_async :: forall m.
1105+
( MonadMaskingState m
1106+
, MonadFork m
1107+
, MonadSTM m
1108+
, MonadDelay m
1109+
)
1110+
=> MaskingState -> m Property
1111+
prop_catch_throwTo_masking_state_async ms = do
1112+
sgnl <- newEmptyTMVarIO
1113+
var <- newEmptyTMVarIO
1114+
tid <- forkIO $
1115+
setMaskingState ms $ \unmask ->
1116+
(do atomically $ putTMVar sgnl ()
1117+
unmask (threadDelay 1)
1118+
)
1119+
`catch` \(_ :: IOError) -> do
1120+
ms' <- getMaskingState
1121+
atomically $ putTMVar var (ms' === ms `maxMS` MaskedInterruptible)
1122+
-- wait until the catch handler is installed
1123+
atomically $ takeTMVar sgnl
1124+
-- the forked thread is interruptibly blocked on `threadDelay`,
1125+
-- `throwTo` will not block
1126+
throwTo tid (userError "error")
1127+
atomically $ takeTMVar var
1128+
1129+
1130+
unit_catch_throwTo_masking_state_async_IO :: MaskingState -> Property
1131+
unit_catch_throwTo_masking_state_async_IO =
1132+
ioProperty . prop_catch_throwTo_masking_state_async
1133+
1134+
unit_catch_throwTo_masking_state_async_ST :: MaskingState -> Property
1135+
unit_catch_throwTo_masking_state_async_ST ms =
1136+
runSimOrThrow (prop_catch_throwTo_masking_state_async ms)
1137+
1138+
1139+
-- | Like 'prop_catch_throwTo_masking_state_async' but 'throwTo' will block if
1140+
-- masking state is set to 'MaskedUninterruptible'. This makes sure that the
1141+
-- 'willBlock' branch of 'ThrowTo' in 'schedule' is covered.
1142+
--
1143+
prop_catch_throwTo_masking_state_async_mayblock :: forall m.
1144+
( MonadMaskingState m
1145+
, MonadFork m
1146+
, MonadSTM m
1147+
, MonadDelay m
1148+
)
1149+
=> MaskingState -> m Property
1150+
prop_catch_throwTo_masking_state_async_mayblock ms = do
1151+
sgnl <- newEmptyTMVarIO
1152+
var <- newEmptyTMVarIO
1153+
tid <- forkIO $
1154+
setMaskingState ms $ \unmask ->
1155+
(do atomically $ putTMVar sgnl ()
1156+
-- if 'ms' is 'MaskedUninterruptible' then the following
1157+
-- 'threadDelay' will block.
1158+
threadDelay 0.1
1159+
-- make sure that even in 'MaskedUninterruptible' the thread
1160+
-- unblocks so async exceptions can be delivered.
1161+
unmask (threadDelay 1)
1162+
)
1163+
`catch` \(_ :: IOError) -> do
1164+
ms' <- getMaskingState
1165+
atomically $ putTMVar var (ms' === ms `maxMS` MaskedInterruptible)
1166+
-- wait until the catch handler is installed
1167+
atomically $ takeTMVar sgnl
1168+
threadDelay 0.05
1169+
-- we know the forked thread is interruptibly blocked on `threadDelay`,
1170+
-- `throwTo` will not be blocked.
1171+
throwTo tid (userError "error")
1172+
atomically $ takeTMVar var
1173+
1174+
unit_catch_throwTo_masking_state_async_mayblock_IO :: MaskingState -> Property
1175+
unit_catch_throwTo_masking_state_async_mayblock_IO =
1176+
ioProperty . prop_catch_throwTo_masking_state_async_mayblock
1177+
1178+
unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property
1179+
unit_catch_throwTo_masking_state_async_mayblock_ST ms =
1180+
runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms)
1181+
8901182
--
8911183
-- Utils
8921184
--

0 commit comments

Comments
 (0)