Skip to content

Commit cf107e9

Browse files
iohk-bors[bot]coot
iohk-bors[bot]
and
coot
authored
Merge #3632
3632: Connection Manager tests using IOSimPOR r=coot a=coot - server-tests: clean the exported `tests` spec - io-sim-por: written & read tvars are swapped - io-sim-por: refactor racingEffects - io-sim-por: refactor the invariant function - io-sim-por: expand tracing of IOSimPOR events - io-sim: ppDebug helper function - io-sim: trace deschedule events - io-sim-por: added EventSimStart - io-sim-por: update timeout's TVar's vector clocks - io-sim-por: exclude forked threads from concurrent threads - io-sim-por: refactor traceFinalRacesFound - io-sim-por: compareTraces should not drop any events - io-sim-por: SimPORTrace Co-authored-by: Marcin Szamotulski <[email protected]>
2 parents d377c58 + bcfd34f commit cf107e9

File tree

8 files changed

+479
-278
lines changed

8 files changed

+479
-278
lines changed

‎io-sim/io-sim.cabal

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,10 +28,12 @@ library
2828
exposed-modules: Data.List.Trace,
2929
Control.Monad.IOSim,
3030
Control.Monad.IOSim.Types
31-
other-modules: Control.Monad.IOSim.Internal,
31+
other-modules: Control.Monad.IOSim.CommonTypes,
32+
Control.Monad.IOSim.Internal,
3233
Control.Monad.IOSim.InternalTypes,
3334
Control.Monad.IOSim.STM,
3435
Control.Monad.IOSimPOR.Internal,
36+
Control.Monad.IOSimPOR.Types,
3537
Control.Monad.IOSimPOR.QuickCheckUtils,
3638
Control.Monad.IOSimPOR.Timeout
3739
default-language: Haskell2010
@@ -53,6 +55,7 @@ library
5355
parallel,
5456
pretty-simple,
5557
psqueues >=0.2 && <0.3,
58+
text,
5659
time >=1.9.1 && <1.11,
5760
quiet,
5861
QuickCheck,

‎io-sim/src/Control/Monad/IOSim.hs

Lines changed: 34 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ module Control.Monad.IOSim
1616
, runSimTrace
1717
, controlSimTrace
1818
, exploreSimTrace
19+
, ScheduleMod (..)
1920
, ScheduleControl (..)
2021
, runSimTraceST
2122
, liftST
@@ -26,7 +27,7 @@ module Control.Monad.IOSim
2627
, unshareClock
2728
-- * Simulation trace
2829
, type SimTrace
29-
, Trace (Cons, Nil, Trace, SimTrace, TraceDeadlock, TraceLoop,
30+
, Trace (Cons, Nil, Trace, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop,
3031
TraceMainReturn, TraceMainException, TraceRacesFound)
3132
, SimResult (..)
3233
, SimEvent (..)
@@ -38,6 +39,7 @@ module Control.Monad.IOSim
3839
, ppTrace_
3940
, ppEvents
4041
, ppSimEvent
42+
, ppDebug
4143
-- ** Selectors
4244
, traceEvents
4345
, traceResult
@@ -57,7 +59,7 @@ module Control.Monad.IOSim
5759
, printTraceEventsSay
5860
-- * Exploration options
5961
, ExplorationSpec
60-
, ExplorationOptions
62+
, ExplorationOptions (..)
6163
, stdExplorationOptions
6264
, withScheduleBound
6365
, withBranching
@@ -133,6 +135,7 @@ selectTraceRaces :: SimTrace a -> [ScheduleControl]
133135
selectTraceRaces = go
134136
where
135137
go (SimTrace _ _ _ _ trace) = go trace
138+
go (SimPORTrace _ _ _ _ _ trace) = go trace
136139
go (TraceRacesFound races trace) =
137140
races ++ go trace
138141
go _ = []
@@ -158,9 +161,10 @@ detachTraceRaces trace = unsafePerformIO $ do
158161
saveRaces r t = unsafePerformIO $ do
159162
modifyIORef races (r:)
160163
return t
161-
let go (SimTrace a b c d trace) = SimTrace a b c d $ go trace
162-
go (TraceRacesFound r trace) = saveRaces r $ go trace
163-
go t = t
164+
let go (SimTrace a b c d trace) = SimTrace a b c d $ go trace
165+
go (SimPORTrace a b c d e trace) = SimPORTrace a b c d e $ go trace
166+
go (TraceRacesFound r trace) = saveRaces r $ go trace
167+
go t = t
164168
return (readRaces,go trace)
165169

166170
-- | Select all the traced values matching the expected type. This relies on
@@ -228,6 +232,10 @@ traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v )
228232
case fn (seType eventCtx) of
229233
Nothing -> acc
230234
Just b -> Cons b acc
235+
SimPOREvent{} ->
236+
case fn (seType eventCtx) of
237+
Nothing -> acc
238+
Just b -> Cons b acc
231239
)
232240
undefined -- it is ignored
233241

@@ -304,6 +312,7 @@ traceResult :: Bool -> SimTrace a -> Either Failure a
304312
traceResult strict = go
305313
where
306314
go (SimTrace _ _ _ _ t) = go t
315+
go (SimPORTrace _ _ _ _ _ t) = go t
307316
go (TraceRacesFound _ t) = go t
308317
go (TraceMainReturn _ _ tids@(_:_))
309318
| strict = Left (FailureSloppyShutdown tids)
@@ -313,9 +322,11 @@ traceResult strict = go
313322
go TraceLoop{} = error "Impossible: traceResult TraceLoop{}"
314323

315324
traceEvents :: SimTrace a -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
316-
traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)
317-
: traceEvents t
318-
traceEvents _ = []
325+
traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event)
326+
: traceEvents t
327+
traceEvents (SimPORTrace time tid _ tlbl event t) = (time, tid, tlbl, event)
328+
: traceEvents t
329+
traceEvents _ = []
319330

320331

321332
ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
@@ -460,23 +471,28 @@ compareTraces (Just passing) trace = unsafePerformIO $ do
460471
sleeper <- newIORef Nothing
461472
return (unsafePerformIO $ readIORef sleeper,
462473
go sleeper passing trace)
463-
where go sleeper (SimTrace tpass tidpass _ _ pass')
464-
(SimTrace tfail tidfail tlfail evfail fail')
474+
where go sleeper (SimPORTrace tpass tidpass _ _ _ pass')
475+
(SimPORTrace tfail tidfail tstepfail tlfail evfail fail')
465476
| (tpass,tidpass) == (tfail,tidfail) =
466-
SimTrace tfail tidfail tlfail evfail $
467-
go sleeper pass' fail'
468-
go sleeper (SimTrace tpass tidpass tlpass _ _) fail =
477+
SimPORTrace tfail tidfail tstepfail tlfail evfail
478+
$ go sleeper pass' fail'
479+
go sleeper (SimPORTrace tpass tidpass tsteppass tlpass _ _) fail =
469480
unsafePerformIO $ do
470481
writeIORef sleeper $ Just ((tpass, tidpass, tlpass),Set.empty)
471-
return $ SimTrace tpass tidpass tlpass EventThreadSleep $
472-
wakeup sleeper tidpass fail
482+
return $ SimPORTrace tpass tidpass tsteppass tlpass EventThreadSleep
483+
$ wakeup sleeper tidpass fail
484+
go _ SimTrace {} _ = error "compareTraces: invariant violation"
485+
go _ _ SimTrace {} = error "compareTraces: invariant violation"
473486
go _ _ fail = fail
474-
wakeup sleeper tidpass (SimTrace tfail tidfail tlfail evfail fail')
487+
488+
wakeup sleeper tidpass
489+
fail@(SimPORTrace tfail tidfail tstepfail tlfail evfail fail')
475490
| tidpass == tidfail =
476-
SimTrace tfail tidfail tlfail EventThreadWake fail'
491+
SimPORTrace tfail tidfail tstepfail tlfail EventThreadWake fail
477492
| otherwise = unsafePerformIO $ do
478493
Just (slp,racing) <- readIORef sleeper
479494
writeIORef sleeper $ Just (slp,Set.insert (tidfail,tlfail) racing)
480-
return $ SimTrace tfail tidfail tlfail evfail
495+
return $ SimPORTrace tfail tidfail tstepfail tlfail evfail
481496
$ wakeup sleeper tidpass fail'
497+
wakeup _ _ SimTrace {} = error "compareTraces: invariant violation"
482498
wakeup _ _ fail = fail

‎io-sim/src/Control/Monad/IOSim/CommonTypes.hs

Lines changed: 89 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,89 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE StandaloneDeriving #-}
5+
6+
-- | Common types shared between `IOSim` and `IOSimPOR`.
7+
--
8+
module Control.Monad.IOSim.CommonTypes where
9+
10+
import Control.Monad.ST.Lazy
11+
12+
import Data.Function (on)
13+
import Data.Map (Map)
14+
import Data.Set (Set)
15+
import Data.STRef.Lazy
16+
import Data.Typeable (Typeable)
17+
18+
data ThreadId = RacyThreadId [Int]
19+
| ThreadId [Int] -- non racy threads have higher priority
20+
deriving (Eq, Ord, Show)
21+
22+
childThreadId :: ThreadId -> Int -> ThreadId
23+
childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i])
24+
childThreadId (ThreadId is) i = ThreadId (is ++ [i])
25+
26+
setRacyThread :: ThreadId -> ThreadId
27+
setRacyThread (ThreadId is) = RacyThreadId is
28+
setRacyThread tid@RacyThreadId{} = tid
29+
30+
31+
newtype TVarId = TVarId Int deriving (Eq, Ord, Enum, Show)
32+
newtype TimeoutId = TimeoutId Int deriving (Eq, Ord, Enum, Show)
33+
newtype ClockId = ClockId [Int] deriving (Eq, Ord, Show)
34+
newtype VectorClock = VectorClock { getVectorClock :: Map ThreadId Int }
35+
deriving Show
36+
37+
unTimeoutId :: TimeoutId -> Int
38+
unTimeoutId (TimeoutId a) = a
39+
40+
type ThreadLabel = String
41+
type TVarLabel = String
42+
43+
data TVar s a = TVar {
44+
45+
-- | The identifier of this var.
46+
--
47+
tvarId :: !TVarId,
48+
49+
-- | Label.
50+
tvarLabel :: !(STRef s (Maybe TVarLabel)),
51+
52+
-- | The var's current value
53+
--
54+
tvarCurrent :: !(STRef s a),
55+
56+
-- | A stack of undo values. This is only used while executing a
57+
-- transaction.
58+
--
59+
tvarUndo :: !(STRef s [a]),
60+
61+
-- | Thread Ids of threads blocked on a read of this var. It is
62+
-- represented in reverse order of thread wakeup, without duplicates.
63+
--
64+
-- To avoid duplicates efficiently, the operations rely on a copy of the
65+
-- thread Ids represented as a set.
66+
--
67+
tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId)),
68+
69+
-- | The vector clock of the current value.
70+
--
71+
tvarVClock :: !(STRef s VectorClock),
72+
73+
-- | Callback to construct a trace which will be attached to the dynamic
74+
-- trace.
75+
tvarTrace :: !(STRef s (Maybe (MkTVarTrace s a)))
76+
}
77+
78+
instance Eq (TVar s a) where
79+
(==) = on (==) tvarId
80+
81+
data MkTVarTrace s a where
82+
MkTVarTrace :: forall s a tr. Typeable tr => (Maybe a -> a -> ST s tr)
83+
-> MkTVarTrace s a
84+
85+
data SomeTVar s where
86+
SomeTVar :: !(TVar s a) -> SomeTVar s
87+
88+
data Deschedule = Yield | Interruptable | Blocked | Terminated | Sleep
89+
deriving Show

‎io-sim/src/Control/Monad/IOSim/Internal.hs

Lines changed: 37 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,9 @@ import Control.Monad.Class.MonadThrow hiding (getMaskingState)
7979
import Control.Monad.Class.MonadTime
8080
import Control.Monad.Class.MonadTimer
8181

82-
import Control.Monad.IOSim.Types
82+
import Control.Monad.IOSim.Types (SimEvent)
83+
import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),
84+
Trace(SimPORTrace))
8385
import Control.Monad.IOSim.InternalTypes
8486

8587
--
@@ -201,15 +203,19 @@ schedule thread@Thread{
201203
ForkFrame -> do
202204
-- this thread is done
203205
trace <- deschedule Terminated thread simstate
204-
return $ SimTrace time tid tlbl EventThreadFinished trace
206+
return $ SimTrace time tid tlbl EventThreadFinished
207+
$ SimTrace time tid tlbl (EventDeschedule Terminated)
208+
$ trace
205209

206210
MaskFrame k maskst' ctl' -> do
207211
-- pop the control stack, restore thread-local state
208212
let thread' = thread { threadControl = ThreadControl (k x) ctl'
209213
, threadMasking = maskst' }
210214
-- but if we're now unmasked, check for any pending async exceptions
211215
trace <- deschedule Interruptable thread' simstate
212-
return (SimTrace time tid tlbl (EventMask maskst') trace)
216+
return $ SimTrace time tid tlbl (EventMask maskst')
217+
$ SimTrace time tid tlbl (EventDeschedule Interruptable)
218+
$ trace
213219

214220
CatchFrame _handler k ctl' -> do
215221
-- pop the control stack and continue
@@ -235,8 +241,10 @@ schedule thread@Thread{
235241
| otherwise -> do
236242
-- An unhandled exception in any other thread terminates the thread
237243
trace <- deschedule Terminated thread simstate
238-
return (SimTrace time tid tlbl (EventThrow e) $
239-
SimTrace time tid tlbl (EventThreadUnhandled e) trace)
244+
return $ SimTrace time tid tlbl (EventThrow e)
245+
$ SimTrace time tid tlbl (EventThreadUnhandled e)
246+
$ SimTrace time tid tlbl (EventDeschedule Terminated)
247+
$ trace
240248

241249
Catch action' handler k -> do
242250
-- push the failure and success continuations onto the control stack
@@ -412,30 +420,32 @@ schedule thread@Thread{
412420
-- that algorithms are not sensitive to the exact policy, so long
413421
-- as it is a fair policy (all runnable threads eventually run).
414422
trace <- deschedule Yield thread' simstate' { nextVid = nextVid' }
415-
return $
416-
SimTrace time tid tlbl (EventTxCommitted vids [nextVid..pred nextVid']) $
417-
traceMany
418-
[ (time, tid', tlbl', EventTxWakeup vids')
419-
| tid' <- unblocked
420-
, let tlbl' = lookupThreadLabel tid' threads
421-
, let Just vids' = Set.toList <$> Map.lookup tid' wokeby ] $
422-
traceMany
423-
[ (time, tid, tlbl, EventLog tr)
424-
| tr <- tvarTraces
425-
]
426-
trace
423+
return $ SimTrace time tid tlbl (EventTxCommitted
424+
vids [nextVid..pred nextVid'] Nothing)
425+
$ traceMany
426+
[ (time, tid', tlbl', EventTxWakeup vids')
427+
| tid' <- unblocked
428+
, let tlbl' = lookupThreadLabel tid' threads
429+
, let Just vids' = Set.toList <$> Map.lookup tid' wokeby ]
430+
$ traceMany
431+
[ (time, tid, tlbl, EventLog tr)
432+
| tr <- tvarTraces ]
433+
$ SimTrace time tid tlbl (EventDeschedule Yield)
434+
$ trace
427435

428436
StmTxAborted _read e -> do
429437
-- schedule this thread to immediately raise the exception
430438
let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
431439
trace <- schedule thread' simstate
432-
return $ SimTrace time tid tlbl EventTxAborted trace
440+
return $ SimTrace time tid tlbl (EventTxAborted Nothing) trace
433441

434442
StmTxBlocked read -> do
435443
mapM_ (\(SomeTVar tvar) -> blockThreadOnTVar tid tvar) read
436444
vids <- traverse (\(SomeTVar tvar) -> labelledTVarId tvar) read
437445
trace <- deschedule Blocked thread simstate
438-
return $ SimTrace time tid tlbl (EventTxBlocked vids) trace
446+
return $ SimTrace time tid tlbl (EventTxBlocked vids Nothing)
447+
$ SimTrace time tid tlbl (EventDeschedule Blocked)
448+
$ trace
439449

440450
GetThreadId k -> do
441451
let thread' = thread { threadControl = ThreadControl (k tid) ctl }
@@ -463,9 +473,11 @@ schedule thread@Thread{
463473
trace <-
464474
case maskst' of
465475
-- If we're now unmasked then check for any pending async exceptions
466-
Unmasked -> deschedule Interruptable thread' simstate
476+
Unmasked -> SimTrace time tid tlbl (EventDeschedule Interruptable)
477+
<$> deschedule Interruptable thread' simstate
467478
_ -> schedule thread' simstate
468-
return (SimTrace time tid tlbl (EventMask maskst') trace)
479+
return $ SimTrace time tid tlbl (EventMask maskst')
480+
$ trace
469481

470482
ThrowTo e tid' _ | tid' == tid -> do
471483
-- Throw to ourself is equivalent to a synchronous throw,
@@ -488,6 +500,7 @@ schedule thread@Thread{
488500
trace <- deschedule Blocked thread' simstate { threads = threads' }
489501
return $ SimTrace time tid tlbl (EventThrowTo e tid')
490502
$ SimTrace time tid tlbl EventThrowToBlocked
503+
$ SimTrace time tid tlbl (EventDeschedule Blocked)
491504
$ trace
492505
else do
493506
-- The target thread has async exceptions unmasked, or is masked but
@@ -524,8 +537,6 @@ threadInterruptible thread =
524537
| otherwise -> False
525538
MaskedUninterruptible -> False
526539

527-
data Deschedule = Yield | Interruptable | Blocked | Terminated
528-
529540
deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
530541
deschedule Yield thread simstate@SimState{runqueue, threads} =
531542

@@ -597,6 +608,9 @@ deschedule Terminated thread simstate@SimState{ curTime = time, threads } = do
597608
, let tlbl' = lookupThreadLabel tid' threads ]
598609
trace
599610

611+
deschedule Sleep _thread _simstate =
612+
error "IOSim: impossible happend"
613+
600614
-- When there is no current running thread but the runqueue is non-empty then
601615
-- schedule the next one to run.
602616
reschedule :: SimState s a -> ST s (SimTrace a)

‎io-sim/src/Control/Monad/IOSim/InternalTypes.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Control.Monad.Class.MonadThrow (MaskingState (..))
1313

1414
import Control.Monad.IOSim.Types (SimA)
1515

16-
1716
-- We hide the type @b@ here, so it's useful to bundle these two parts
1817
-- together, rather than having Thread have an extential type, which
1918
-- makes record updates awkward.

0 commit comments

Comments
 (0)