Skip to content

Commit 3925fad

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 3925fad

File tree

6 files changed

+70
-47
lines changed

6 files changed

+70
-47
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`, `MVar` and a few others - except for `TChan`.
1113

1214
## 1.6.0.0
1315

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

Lines changed: 20 additions & 2 deletions
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 shared 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 }
@@ -139,7 +157,7 @@ data TVar s a = TVar {
139157
tvarVClock :: !(STRef s VectorClock),
140158

141159
-- | Callback to construct a trace which will be attached to the dynamic
142-
-- trace.
160+
-- trace each time the `TVar` is committed.
143161
tvarTrace :: !(STRef s (Maybe (Maybe a -> a -> ST s TraceValue)))
144162
}
145163

‎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: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -90,8 +90,8 @@ 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,
94-
retry)
93+
TChanDefault (..), TMVarDefault (..), TSemDefault (..), TraceValue,
94+
atomically, retry)
9595
import Control.Monad.Class.MonadSTM.Internal qualified as MonadSTM
9696
import Control.Monad.Class.MonadTest
9797
import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)
@@ -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.

0 commit comments

Comments
 (0)