Skip to content

Commit 27e22ce

Browse files
cootcoot
committed
io-sim: improve labels of shared variables
`TVar`s are used to emulate `TMVar`s and `MVar`s, and thus can have three different roles. For each role `TVarId` provides a constructor, which makes it easier to distinguish them in the trace.
1 parent 6d84047 commit 27e22ce

File tree

6 files changed

+68
-45
lines changed

6 files changed

+68
-45
lines changed

‎io-sim/CHANGELOG.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,8 @@
88
- `Show` instance for `ScheduleMod` now prints `ThreadId`s in a slightly nicer
99
way, matching the way those steps would be traced in the `SimTrace`.
1010
- Implement `MonadLabelledMVar` instance for `(IOSim s)`
11+
- `TVarId` is now a sum type with one constructor per `TVar` role, e.g. `TVar`,
12+
`TMVar` or `MVar`.
1113

1214
## 1.6.0.0
1315

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

Lines changed: 19 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ module Control.Monad.IOSim.CommonTypes
1717
, childThreadId
1818
, setRacyThread
1919
, TVarId (..)
20+
, VarId
2021
, TimeoutId (..)
2122
, ClockId (..)
2223
, VectorClock (..)
@@ -92,7 +93,24 @@ ppStepId (tid, step) | step < 0
9293
ppStepId (tid, step) = concat [ppIOSimThreadId tid, ".", show step]
9394

9495

95-
newtype TVarId = TVarId Int deriving (Eq, Ord, Enum, Show)
96+
type VarId = Int
97+
-- | TVar's are used to emulate other various variables. Each one comes with
98+
-- its own id constructor.
99+
data TVarId =
100+
TVarId !VarId
101+
-- ^ a `TVar`
102+
| TMVarId !VarId
103+
-- ^ a `TMVar` simulated by a `TVar`.
104+
| MVarId !VarId
105+
-- ^ an `MVar` simulated by a `TVar`.
106+
| TQueueId !VarId
107+
-- ^ a 'TQueue` simulated by a `TVar`.
108+
| TBQueueId !VarId
109+
-- ^ a 'TBQueue` simulated by a `TVar`.
110+
| TSemId !VarId
111+
-- ^ a 'TSem` simulated by a `TVar`.
112+
-- TODO: `TChan`
113+
deriving (Eq, Ord, Show)
96114
newtype TimeoutId = TimeoutId Int deriving (Eq, Ord, Enum, Show)
97115
newtype ClockId = ClockId [Int] deriving (Eq, Ord, Show)
98116
newtype VectorClock = VectorClock { getVectorClock :: Map IOSimThreadId Int }

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

Lines changed: 16 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ data SimState s a = SimState {
149149
timers :: !(Timeouts s),
150150
-- | list of clocks
151151
clocks :: !(Map ClockId UTCTime),
152-
nextVid :: !TVarId, -- ^ next unused 'TVarId'
152+
nextVid :: !VarId, -- ^ next unused 'VarId'
153153
nextTmid :: !TimeoutId -- ^ next unused 'TimeoutId'
154154
}
155155

@@ -161,7 +161,7 @@ initialState =
161161
curTime = Time 0,
162162
timers = PSQ.empty,
163163
clocks = Map.singleton (ClockId []) epoch1970,
164-
nextVid = TVarId 0,
164+
nextVid = 0,
165165
nextTmid = TimeoutId 0
166166
}
167167
where
@@ -358,7 +358,7 @@ schedule !thread@Thread{
358358
error "schedule: StartTimeout: Impossible happened"
359359

360360
StartTimeout d action' k -> do
361-
!lock <- TMVar <$> execNewTVar nextVid (Just $! "lock-" ++ show nextTmid) Nothing
361+
!lock <- TMVar <$> execNewTVar (TMVarId nextVid) (Just $! "lock-" ++ show nextTmid) Nothing
362362
let !expiry = d `addTime` time
363363
!timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers
364364
!thread' = thread { threadControl =
@@ -376,18 +376,18 @@ schedule !thread@Thread{
376376
schedule thread' simstate { timers = PSQ.delete tmid timers }
377377

378378
RegisterDelay d k | d < 0 -> do
379-
!tvar <- execNewTVar nextVid
379+
!tvar <- execNewTVar (TVarId nextVid)
380380
(Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
381381
True
382382
let !expiry = d `addTime` time
383383
!thread' = thread { threadControl = ThreadControl (k tvar) ctl }
384384
trace <- schedule thread' simstate { nextVid = succ nextVid }
385-
return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) $
385+
return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $
386386
SimTrace time tid tlbl (EventRegisterDelayFired nextTmid) $
387387
trace)
388388

389389
RegisterDelay d k -> do
390-
!tvar <- execNewTVar nextVid
390+
!tvar <- execNewTVar (TVarId nextVid)
391391
(Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
392392
False
393393
let !expiry = d `addTime` time
@@ -397,7 +397,7 @@ schedule !thread@Thread{
397397
, nextVid = succ nextVid
398398
, nextTmid = succ nextTmid }
399399
return (SimTrace time tid tlbl
400-
(EventRegisterDelayCreated nextTmid nextVid expiry) trace)
400+
(EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace)
401401

402402
ThreadDelay d k | d < 0 -> do
403403
let !expiry = d `addTime` time
@@ -424,12 +424,12 @@ schedule !thread@Thread{
424424
!expiry = d `addTime` time
425425
!thread' = thread { threadControl = ThreadControl (k t) ctl }
426426
trace <- schedule thread' simstate { nextTmid = succ nextTmid }
427-
return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) $
427+
return (SimTrace time tid tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) $
428428
SimTrace time tid tlbl (EventTimerCancelled nextTmid) $
429429
trace)
430430

431431
NewTimeout d k -> do
432-
!tvar <- execNewTVar nextVid
432+
!tvar <- execNewTVar (TVarId nextVid)
433433
(Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")
434434
TimeoutPending
435435
let !expiry = d `addTime` time
@@ -439,7 +439,7 @@ schedule !thread@Thread{
439439
trace <- schedule thread' simstate { timers = timers'
440440
, nextVid = succ nextVid
441441
, nextTmid = succ nextTmid }
442-
return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace)
442+
return (SimTrace time tid tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace)
443443

444444
CancelTimeout (Timeout tvar tmid) k -> do
445445
let !timers' = PSQ.delete tmid timers
@@ -1030,7 +1030,7 @@ execAtomically :: forall s a c.
10301030
Time
10311031
-> IOSimThreadId
10321032
-> Maybe ThreadLabel
1033-
-> TVarId
1033+
-> VarId
10341034
-> StmA s a
10351035
-> (StmTxResult s a -> ST s (SimTrace c))
10361036
-> ST s (SimTrace c)
@@ -1043,7 +1043,7 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
10431043
-> Map TVarId (SomeTVar s) -- set of vars written
10441044
-> [SomeTVar s] -- vars written in order (no dups)
10451045
-> [SomeTVar s] -- vars created in order
1046-
-> TVarId -- var fresh name supply
1046+
-> VarId -- var fresh name supply
10471047
-> StmA s b
10481048
-> ST s (SimTrace c)
10491049
go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =
@@ -1145,8 +1145,8 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
11451145
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
11461146
go ctl' read Map.empty [] [] nextVid a
11471147

1148-
NewTVar !mbLabel x k -> do
1149-
!v <- execNewTVar nextVid mbLabel x
1148+
NewTVar mkId !mbLabel x k -> do
1149+
!v <- execNewTVar (mkId nextVid) mbLabel x
11501150
go ctl read written writtenSeq (SomeTVar v : createdSeq) (succ nextVid) (k v)
11511151

11521152
LabelTVar !label tvar k -> do
@@ -1229,14 +1229,14 @@ execAtomically' = go Map.empty
12291229

12301230

12311231
execNewTVar :: TVarId -> Maybe String -> a -> ST s (TVar s a)
1232-
execNewTVar nextVid !mbLabel x = do
1232+
execNewTVar !tvarId !mbLabel x = do
12331233
!tvarLabel <- newSTRef mbLabel
12341234
!tvarCurrent <- newSTRef x
12351235
!tvarUndo <- newSTRef $! []
12361236
!tvarBlocked <- newSTRef ([], Set.empty)
12371237
!tvarVClock <- newSTRef $! VectorClock Map.empty
12381238
!tvarTrace <- newSTRef $! Nothing
1239-
return TVar {tvarId = nextVid, tvarLabel,
1239+
return TVar {tvarId, tvarLabel,
12401240
tvarCurrent, tvarUndo, tvarBlocked, tvarVClock,
12411241
tvarTrace}
12421242

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -264,7 +264,7 @@ newEmptyMVarDefault = MVar <$> newTVarIO (MVarEmpty mempty mempty)
264264
labelMVarDefault
265265
:: MonadLabelledSTM m
266266
=> MVarDefault m a -> String -> m ()
267-
labelMVarDefault (MVar tvar) = atomically . labelTVar tvar . (<> "-MVar")
267+
labelMVarDefault (MVar tvar) = atomically . labelTVar tvar
268268

269269
newMVarDefault :: MonadSTM m => a -> m (MVarDefault m a)
270270
newMVarDefault a = MVar <$> newTVarIO (MVarFull a mempty)

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

Lines changed: 14 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -90,7 +90,7 @@ import Control.Monad.Class.MonadSay
9090
import Control.Monad.Class.MonadST
9191
import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..),
9292
MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..), TArrayDefault,
93-
TChanDefault, TMVarDefault, TSemDefault, TraceValue, atomically,
93+
TChanDefault (..), TMVarDefault (..), TSemDefault (..), TraceValue, atomically,
9494
retry)
9595
import Control.Monad.Class.MonadSTM.Internal qualified as MonadSTM
9696
import Control.Monad.Class.MonadTest
@@ -219,7 +219,7 @@ data StmA s a where
219219
ThrowStm :: SomeException -> StmA s a
220220
CatchStm :: StmA s a -> (SomeException -> StmA s a) -> (a -> StmA s b) -> StmA s b
221221

222-
NewTVar :: Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b
222+
NewTVar :: (VarId -> TVarId) -> Maybe String -> x -> (TVar s x -> StmA s b) -> StmA s b
223223
LabelTVar :: String -> TVar s a -> StmA s b -> StmA s b
224224
ReadTVar :: TVar s a -> (a -> StmA s b) -> StmA s b
225225
WriteTVar :: TVar s a -> a -> StmA s b -> StmA s b
@@ -508,14 +508,14 @@ instance MonadSTM (IOSim s) where
508508

509509
atomically action = IOSim $ oneShot $ \k -> Atomically action k
510510

511-
newTVar x = STM $ oneShot $ \k -> NewTVar Nothing x k
511+
newTVar x = STM $ oneShot $ \k -> NewTVar TVarId Nothing x k
512512
readTVar tvar = STM $ oneShot $ \k -> ReadTVar tvar k
513513
writeTVar tvar x = STM $ oneShot $ \k -> WriteTVar tvar x (k ())
514514
retry = STM $ oneShot $ \_ -> Retry
515515
orElse a b = STM $ oneShot $ \k -> OrElse (runSTM a) (runSTM b) k
516516

517-
newTMVar = MonadSTM.newTMVarDefault
518-
newEmptyTMVar = MonadSTM.newEmptyTMVarDefault
517+
newTMVar = \a -> STM $ oneShot $ \k -> NewTVar TMVarId Nothing (Just a) (k . TMVar)
518+
newEmptyTMVar = STM $ oneShot $ \k -> NewTVar TMVarId Nothing Nothing (k . TMVar)
519519
takeTMVar = MonadSTM.takeTMVarDefault
520520
tryTakeTMVar = MonadSTM.tryTakeTMVarDefault
521521
putTMVar = MonadSTM.putTMVarDefault
@@ -526,7 +526,7 @@ instance MonadSTM (IOSim s) where
526526
writeTMVar = MonadSTM.writeTMVarDefault
527527
isEmptyTMVar = MonadSTM.isEmptyTMVarDefault
528528

529-
newTQueue = newTQueueDefault
529+
newTQueue = STM $ oneShot $ \k -> NewTVar TQueueId Nothing ([], []) (k . TQueue)
530530
readTQueue = readTQueueDefault
531531
tryReadTQueue = tryReadTQueueDefault
532532
peekTQueue = peekTQueueDefault
@@ -536,7 +536,10 @@ instance MonadSTM (IOSim s) where
536536
isEmptyTQueue = isEmptyTQueueDefault
537537
unGetTQueue = unGetTQueueDefault
538538

539-
newTBQueue = newTBQueueDefault
539+
newTBQueue size | size >= fromIntegral (maxBound :: Int)
540+
= error "newTBQueue: size larger than Int"
541+
| otherwise
542+
= STM $ oneShot $ \k -> NewTVar TBQueueId Nothing ([], 0, [], size) (k . (`TBQueue` size ))
540543
readTBQueue = readTBQueueDefault
541544
tryReadTBQueue = tryReadTBQueueDefault
542545
peekTBQueue = peekTBQueueDefault
@@ -548,7 +551,7 @@ instance MonadSTM (IOSim s) where
548551
isFullTBQueue = isFullTBQueueDefault
549552
unGetTBQueue = unGetTBQueueDefault
550553

551-
newTSem = MonadSTM.newTSemDefault
554+
newTSem = \i -> STM $ oneShot $ \k -> NewTVar TSemId Nothing i (k . TSem)
552555
waitTSem = MonadSTM.waitTSemDefault
553556
signalTSem = MonadSTM.signalTSemDefault
554557
signalTSemN = MonadSTM.signalTSemNDefault
@@ -588,8 +591,8 @@ instance MonadTraceSTM (IOSim s) where
588591

589592
instance MonadMVar (IOSim s) where
590593
type MVar (IOSim s) = MVarDefault (IOSim s)
591-
newEmptyMVar = newEmptyMVarDefault
592-
newMVar = newMVarDefault
594+
newEmptyMVar = atomically $ STM $ oneShot $ \k -> NewTVar MVarId Nothing (MVarEmpty mempty mempty) (k . MVar)
595+
newMVar = \a -> atomically $ STM $ oneShot $ \k -> NewTVar MVarId Nothing (MVarFull a mempty) (k . MVar)
593596
takeMVar = takeMVarDefault
594597
putMVar = putMVarDefault
595598
tryTakeMVar = tryTakeMVarDefault
@@ -1233,7 +1236,7 @@ data StmTxResult s a =
12331236
![SomeTVar s] -- ^ created tvars
12341237
![Dynamic]
12351238
![String]
1236-
!TVarId -- updated TVarId name supply
1239+
!VarId -- updated TVarId name supply
12371240

12381241
-- | A blocked transaction reports the vars that were read so that the
12391242
-- scheduler can block the thread on those vars.

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

Lines changed: 16 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -195,7 +195,7 @@ data SimState s a = SimState {
195195
-- | timeout locks in order to synchronize the timeout handler and the
196196
-- main thread
197197
clocks :: !(Map ClockId UTCTime),
198-
nextVid :: !TVarId, -- ^ next unused 'TVarId'
198+
nextVid :: !VarId, -- ^ next unused 'TVarId'
199199
nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId'
200200
-- | previous steps (which we may race with).
201201
-- Note this is *lazy*, so that we don't compute races we will not reverse.
@@ -217,7 +217,7 @@ initialState =
217217
curTime = Time 0,
218218
timers = PSQ.empty,
219219
clocks = Map.singleton (ClockId []) epoch1970,
220-
nextVid = TVarId 0,
220+
nextVid = 0,
221221
nextTmid = TimeoutId 0,
222222
races = noRaces,
223223
control = ControlDefault,
@@ -480,7 +480,7 @@ schedule thread@Thread{
480480
error "schedule: StartTimeout: Impossible happened"
481481

482482
StartTimeout d action' k -> do
483-
lock <- TMVar <$> execNewTVar nextVid (Just $! "lock-" ++ show nextTmid) Nothing
483+
lock <- TMVar <$> execNewTVar (TMVarId nextVid) (Just $! "lock-" ++ show nextTmid) Nothing
484484
let expiry = d `addTime` time
485485
timers' = PSQ.insert nextTmid expiry (TimerTimeout tid nextTmid lock) timers
486486
thread' = thread { threadControl =
@@ -496,19 +496,19 @@ schedule thread@Thread{
496496
schedule thread' simstate { timers = PSQ.delete tmid timers }
497497

498498
RegisterDelay d k | d < 0 -> do
499-
tvar <- execNewTVar nextVid
499+
tvar <- execNewTVar (TVarId nextVid)
500500
(Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
501501
True
502502
modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)
503503
let !expiry = d `addTime` time
504504
!thread' = thread { threadControl = ThreadControl (k tvar) ctl }
505505
trace <- schedule thread' simstate { nextVid = succ nextVid }
506-
return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) $
506+
return (SimPORTrace time tid tstep tlbl (EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) $
507507
SimPORTrace time tid tstep tlbl (EventRegisterDelayFired nextTmid) $
508508
trace)
509509

510510
RegisterDelay d k -> do
511-
tvar <- execNewTVar nextVid
511+
tvar <- execNewTVar (TVarId nextVid)
512512
(Just $! "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
513513
False
514514
modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)
@@ -519,7 +519,7 @@ schedule thread@Thread{
519519
, nextVid = succ nextVid
520520
, nextTmid = succ nextTmid }
521521
return (SimPORTrace time tid tstep tlbl
522-
(EventRegisterDelayCreated nextTmid nextVid expiry) trace)
522+
(EventRegisterDelayCreated nextTmid (TVarId nextVid) expiry) trace)
523523

524524
ThreadDelay d k | d < 0 -> do
525525
let expiry = d `addTime` time
@@ -547,12 +547,12 @@ schedule thread@Thread{
547547
expiry = d `addTime` time
548548
thread' = thread { threadControl = ThreadControl (k t) ctl }
549549
trace <- schedule thread' simstate { nextTmid = succ nextTmid }
550-
return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid nextVid expiry) $
550+
return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) $
551551
SimPORTrace time tid tstep tlbl (EventTimerCancelled nextTmid) $
552552
trace)
553553

554554
NewTimeout d k -> do
555-
tvar <- execNewTVar nextVid
555+
tvar <- execNewTVar (TVarId nextVid)
556556
(Just $! "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")
557557
TimeoutPending
558558
modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)
@@ -563,7 +563,7 @@ schedule thread@Thread{
563563
trace <- schedule thread' simstate { timers = timers'
564564
, nextVid = succ (succ nextVid)
565565
, nextTmid = succ nextTmid }
566-
return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid nextVid expiry) trace)
566+
return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid (TVarId nextVid) expiry) trace)
567567

568568
CancelTimeout (Timeout tvar tmid) k -> do
569569
let timers' = PSQ.delete tmid timers
@@ -1358,7 +1358,7 @@ execAtomically :: forall s a c.
13581358
Time
13591359
-> IOSimThreadId
13601360
-> Maybe ThreadLabel
1361-
-> TVarId
1361+
-> VarId
13621362
-> StmA s a
13631363
-> (StmTxResult s a -> ST s (SimTrace c))
13641364
-> ST s (SimTrace c)
@@ -1371,7 +1371,7 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
13711371
-> Map TVarId (SomeTVar s) -- set of vars written
13721372
-> [SomeTVar s] -- vars written in order (no dups)
13731373
-> [SomeTVar s] -- vars created in order
1374-
-> TVarId -- var fresh name supply
1374+
-> VarId -- var fresh name supply
13751375
-> StmA s b
13761376
-> ST s (SimTrace c)
13771377
go !ctl !read !written !writtenSeq !createdSeq !nextVid !action =
@@ -1470,8 +1470,8 @@ execAtomically !time !tid !tlbl !nextVid0 !action0 !k0 =
14701470
let ctl' = BranchFrame (OrElseStmA b) k written writtenSeq createdSeq ctl
14711471
go ctl' read Map.empty [] [] nextVid a
14721472

1473-
NewTVar !mbLabel x k -> do
1474-
!v <- execNewTVar nextVid mbLabel x
1473+
NewTVar mkId !mbLabel x k -> do
1474+
!v <- execNewTVar (mkId nextVid) mbLabel x
14751475
-- record a write to the TVar so we know to update its VClock
14761476
let written' = Map.insert (tvarId v) (SomeTVar v) written
14771477
-- save the value: it will be committed or reverted
@@ -1560,14 +1560,14 @@ execAtomically' = go Map.empty
15601560

15611561

15621562
execNewTVar :: TVarId -> Maybe String -> a -> ST s (TVar s a)
1563-
execNewTVar nextVid !mbLabel x = do
1563+
execNewTVar !tvarId !mbLabel x = do
15641564
tvarLabel <- newSTRef mbLabel
15651565
tvarCurrent <- newSTRef x
15661566
tvarUndo <- newSTRef []
15671567
tvarBlocked <- newSTRef ([], Set.empty)
15681568
tvarVClock <- newSTRef bottomVClock
15691569
tvarTrace <- newSTRef Nothing
1570-
return TVar {tvarId = nextVid, tvarLabel,
1570+
return TVar {tvarId, tvarLabel,
15711571
tvarCurrent, tvarUndo, tvarBlocked, tvarVClock,
15721572
tvarTrace}
15731573

0 commit comments

Comments
 (0)