Skip to content

Commit 9fcd677

Browse files
cootcoot
committed
io-sim: import si-timers library qualified
1 parent baab4cd commit 9fcd677

File tree

3 files changed

+68
-58
lines changed

3 files changed

+68
-58
lines changed

‎io-classes/src/Control/Monad/Class/MonadFork.hs

Lines changed: 22 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -43,16 +43,18 @@ labelThisThread label = myThreadId >>= \tid -> labelThread tid label
4343

4444
class MonadThread m => MonadFork m where
4545

46-
forkIO :: m () -> m (ThreadId m)
47-
forkOn :: Int -> m () -> m (ThreadId m)
48-
forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
49-
forkFinally :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
50-
throwTo :: Exception e => ThreadId m -> e -> m ()
46+
forkIO :: m () -> m (ThreadId m)
47+
forkOn :: Int -> m () -> m (ThreadId m)
48+
forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)
49+
forkFinally :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)
50+
throwTo :: Exception e => ThreadId m -> e -> m ()
5151

52-
killThread :: ThreadId m -> m ()
53-
killThread tid = throwTo tid ThreadKilled
52+
killThread :: ThreadId m -> m ()
53+
killThread tid = throwTo tid ThreadKilled
5454

55-
yield :: m ()
55+
yield :: m ()
56+
57+
getNumCapabilities :: m Int
5658

5759

5860
instance MonadThread IO where
@@ -66,13 +68,14 @@ instance MonadThread IO where
6668
#endif
6769

6870
instance MonadFork IO where
69-
forkIO = IO.forkIO
70-
forkOn = IO.forkOn
71-
forkIOWithUnmask = IO.forkIOWithUnmask
72-
forkFinally = IO.forkFinally
73-
throwTo = IO.throwTo
74-
killThread = IO.killThread
75-
yield = IO.yield
71+
forkIO = IO.forkIO
72+
forkOn = IO.forkOn
73+
forkIOWithUnmask = IO.forkIOWithUnmask
74+
forkFinally = IO.forkFinally
75+
throwTo = IO.throwTo
76+
killThread = IO.killThread
77+
yield = IO.yield
78+
getNumCapabilities = IO.getNumCapabilities
7679

7780
instance MonadThread m => MonadThread (ReaderT r m) where
7881
type ThreadId (ReaderT r m) = ThreadId m
@@ -87,7 +90,9 @@ instance MonadFork m => MonadFork (ReaderT e m) where
8790
let restore' :: ReaderT e m a -> ReaderT e m a
8891
restore' (ReaderT f) = ReaderT $ restore . f
8992
in runReaderT (k restore') e
90-
forkFinally f k = ReaderT $ \e -> forkFinally (runReaderT f e)
91-
$ \err -> runReaderT (k err) e
93+
forkFinally f k = ReaderT $ \e -> forkFinally (runReaderT f e)
94+
$ \err -> runReaderT (k err) e
9295
throwTo e t = lift (throwTo e t)
9396
yield = lift yield
97+
98+
getNumCapabilities = lift getNumCapabilities

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

Lines changed: 31 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -60,9 +60,9 @@ module Control.Monad.IOSim.Types
6060
, ppDebug
6161
, module Control.Monad.IOSim.CommonTypes
6262
, Thrower (..)
63-
, Time (..)
64-
, addTime
65-
, diffTime
63+
, SI.Time (..)
64+
, SI.addTime
65+
, SI.diffTime
6666
-- * Internal API
6767
, Timeout (..)
6868
, newTimeout
@@ -97,7 +97,8 @@ import Control.Monad.Class.MonadTest
9797
import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState)
9898
import Control.Monad.Class.MonadThrow qualified as MonadThrow
9999
import Control.Monad.Class.MonadTime
100-
import Control.Monad.Class.MonadTime.SI
100+
import Control.Monad.Class.MonadTime.SI (DiffTime)
101+
import Control.Monad.Class.MonadTime.SI qualified as SI
101102
import Control.Monad.Class.MonadTimer
102103
import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
103104
import Control.Monad.Class.MonadTimer.SI qualified as SI
@@ -167,7 +168,7 @@ data SimA s a where
167168

168169
LiftST :: StrictST.ST s a -> (a -> SimA s b) -> SimA s b
169170

170-
GetMonoTime :: (Time -> SimA s b) -> SimA s b
171+
GetMonoTime :: (SI.Time -> SimA s b) -> SimA s b
171172
GetWallTime :: (UTCTime -> SimA s b) -> SimA s b
172173
SetWallTime :: UTCTime -> SimA s b -> SimA s b
173174
UnshareClock :: SimA s b -> SimA s b
@@ -479,6 +480,7 @@ instance MonadFork (IOSim s) where
479480
forkIO $ try (restore task) >>= k
480481
throwTo tid e = IOSim $ oneShot $ \k -> ThrowTo (toException e) tid (k ())
481482
yield = IOSim $ oneShot $ \k -> YieldSim (k ())
483+
getNumCapabilities = return 1
482484

483485
instance MonadTest (IOSim s) where
484486
exploreRaces = IOSim $ oneShot $ \k -> ExploreRaces (k ())
@@ -672,10 +674,10 @@ instance MonadMonotonicTimeNSec (IOSim s) where
672674
getMonotonicTimeNSec = IOSim $ oneShot $ \k -> GetMonoTime (k . conv)
673675
where
674676
-- convert time in picoseconds to nanoseconds
675-
conv :: Time -> Word64
676-
conv (Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000)
677+
conv :: SI.Time -> Word64
678+
conv (SI.Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000)
677679

678-
instance MonadMonotonicTime (IOSim s) where
680+
instance SI.MonadMonotonicTime (IOSim s) where
679681
getMonotonicTime = IOSim $ oneShot $ \k -> GetMonoTime k
680682

681683
instance MonadTime (IOSim s) where
@@ -788,14 +790,14 @@ instance MonadEventlog (IOSim s) where
788790
data SimEvent
789791
-- | Used when using `IOSim`.
790792
= SimEvent {
791-
seTime :: !Time,
793+
seTime :: !SI.Time,
792794
seThreadId :: !IOSimThreadId,
793795
seThreadLabel :: !(Maybe ThreadLabel),
794796
seType :: !SimEventType
795797
}
796798
-- | Only used for /IOSimPOR/
797799
| SimPOREvent {
798-
seTime :: !Time,
800+
seTime :: !SI.Time,
799801
seThreadId :: !IOSimThreadId,
800802
seStep :: !Int,
801803
seThreadLabel :: !(Maybe ThreadLabel),
@@ -815,7 +817,7 @@ ppSimEvent :: Int -- ^ width of the time
815817
-> SimEvent
816818
-> String
817819

818-
ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThreadId, seThreadLabel, seType} =
820+
ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = SI.Time time, seThreadId, seThreadLabel, seType} =
819821
printf "%-*s - %-*s %-*s - %s"
820822
timeWidth
821823
(show time)
@@ -825,7 +827,7 @@ ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThread
825827
(fromMaybe "" seThreadLabel)
826828
(ppSimEventType seType)
827829

828-
ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThreadId, seStep, seThreadLabel, seType} =
830+
ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = SI.Time time, seThreadId, seStep, seThreadLabel, seType} =
829831
printf "%-*s - %-*s %-*s - %s"
830832
timeWidth
831833
(show time)
@@ -841,11 +843,11 @@ ppSimEvent _ _ _ (SimRacesFound controls) =
841843

842844
-- | A result type of a simulation.
843845
data SimResult a
844-
= MainReturn !Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
846+
= MainReturn !SI.Time !(Labelled IOSimThreadId) a ![Labelled IOSimThreadId]
845847
-- ^ Return value of the main thread.
846-
| MainException !Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
848+
| MainException !SI.Time !(Labelled IOSimThreadId) SomeException ![Labelled IOSimThreadId]
847849
-- ^ Exception thrown by the main thread.
848-
| Deadlock !Time ![Labelled IOSimThreadId]
850+
| Deadlock !SI.Time ![Labelled IOSimThreadId]
849851
-- ^ Deadlock discovered in the simulation. Deadlocks are discovered if
850852
-- simply the simulation cannot do any progress in a given time slot and
851853
-- there's no event which would advance the time.
@@ -863,7 +865,7 @@ ppSimResult :: Show a
863865
-> SimResult a
864866
-> String
865867
ppSimResult timeWidth tidWidth thLabelWidth r = case r of
866-
MainReturn (Time time) tid a tids ->
868+
MainReturn (SI.Time time) tid a tids ->
867869
printf "%-*s - %-*s %-*s - %s %s"
868870
timeWidth
869871
(show time)
@@ -873,7 +875,7 @@ ppSimResult timeWidth tidWidth thLabelWidth r = case r of
873875
(fromMaybe "" $ l_label tid)
874876
("MainReturn " ++ show a)
875877
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
876-
MainException (Time time) tid e tids ->
878+
MainException (SI.Time time) tid e tids ->
877879
printf "%-*s - %-*s %-*s - %s %s"
878880
timeWidth
879881
(show time)
@@ -883,7 +885,7 @@ ppSimResult timeWidth tidWidth thLabelWidth r = case r of
883885
(fromMaybe "" $ l_label tid)
884886
("MainException " ++ show e)
885887
("[" ++ intercalate "," (ppLabelled ppIOSimThreadId `map` tids) ++ "]")
886-
Deadlock (Time time) tids ->
888+
Deadlock (SI.Time time) tids ->
887889
printf "%-*s - %-*s %-*s - %s %s"
888890
timeWidth
889891
(show time)
@@ -920,12 +922,12 @@ ppTrace tr = Trace.ppTrace
920922
bimaximum
921923
. bimap (const (Max 0, Max 0, Max 0))
922924
(\a -> case a of
923-
SimEvent {seTime = Time time, seThreadId, seThreadLabel} ->
925+
SimEvent {seTime = SI.Time time, seThreadId, seThreadLabel} ->
924926
( Max (length (show time))
925927
, Max (length (show (seThreadId)))
926928
, Max (length seThreadLabel)
927929
)
928-
SimPOREvent {seTime = Time time, seThreadId, seThreadLabel} ->
930+
SimPOREvent {seTime = SI.Time time, seThreadId, seThreadLabel} ->
929931
( Max (length (show time))
930932
, Max (length (show (seThreadId)))
931933
, Max (length seThreadLabel)
@@ -974,13 +976,13 @@ ppDebug = appEndo
974976
. Trace.toList
975977

976978

977-
pattern SimTrace :: Time -> IOSimThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
979+
pattern SimTrace :: SI.Time -> IOSimThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a
978980
-> SimTrace a
979981
pattern SimTrace time threadId threadLabel traceEvent trace =
980982
Trace.Cons (SimEvent time threadId threadLabel traceEvent)
981983
trace
982984

983-
pattern SimPORTrace :: Time -> IOSimThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
985+
pattern SimPORTrace :: SI.Time -> IOSimThreadId -> Int -> Maybe ThreadLabel -> SimEventType -> SimTrace a
984986
-> SimTrace a
985987
pattern SimPORTrace time threadId step threadLabel traceEvent trace =
986988
Trace.Cons (SimPOREvent time threadId step threadLabel traceEvent)
@@ -992,15 +994,15 @@ pattern TraceRacesFound controls trace =
992994
Trace.Cons (SimRacesFound controls)
993995
trace
994996

995-
pattern TraceMainReturn :: Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
997+
pattern TraceMainReturn :: SI.Time -> Labelled IOSimThreadId -> a -> [Labelled IOSimThreadId]
996998
-> SimTrace a
997999
pattern TraceMainReturn time tid a threads = Trace.Nil (MainReturn time tid a threads)
9981000

999-
pattern TraceMainException :: Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
1001+
pattern TraceMainException :: SI.Time -> Labelled IOSimThreadId -> SomeException -> [Labelled IOSimThreadId]
10001002
-> SimTrace a
10011003
pattern TraceMainException time tid err threads = Trace.Nil (MainException time tid err threads)
10021004

1003-
pattern TraceDeadlock :: Time -> [Labelled IOSimThreadId]
1005+
pattern TraceDeadlock :: SI.Time -> [Labelled IOSimThreadId]
10041006
-> SimTrace a
10051007
pattern TraceDeadlock time threads = Trace.Nil (Deadlock time threads)
10061008

@@ -1066,22 +1068,22 @@ data SimEventType
10661068
-- Timeouts, Timers & Delays
10671069
--
10681070

1069-
| EventThreadDelay TimeoutId Time
1071+
| EventThreadDelay TimeoutId SI.Time
10701072
-- ^ thread delayed
10711073
| EventThreadDelayFired TimeoutId
10721074
-- ^ thread woken up after a delay
10731075

1074-
| EventTimeoutCreated TimeoutId IOSimThreadId Time
1076+
| EventTimeoutCreated TimeoutId IOSimThreadId SI.Time
10751077
-- ^ new timeout created (via `timeout`)
10761078
| EventTimeoutFired TimeoutId
10771079
-- ^ timeout fired
10781080

1079-
| EventRegisterDelayCreated TimeoutId TVarId Time
1081+
| EventRegisterDelayCreated TimeoutId TVarId SI.Time
10801082
-- ^ registered delay (via `registerDelay`)
10811083
| EventRegisterDelayFired TimeoutId
10821084
-- ^ registered delay fired
10831085

1084-
| EventTimerCreated TimeoutId TVarId Time
1086+
| EventTimerCreated TimeoutId TVarId SI.Time
10851087
-- ^ a new 'Timeout' created (via `newTimeout`)
10861088
| EventTimerCancelled TimeoutId
10871089
-- ^ a 'Timeout' was cancelled (via `cancelTimeout`)

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

Lines changed: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -80,11 +80,14 @@ import Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)
8080
import Control.Monad.Class.MonadSTM hiding (STM)
8181
import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))
8282
import Control.Monad.Class.MonadThrow as MonadThrow
83-
import Control.Monad.Class.MonadTime
83+
import Control.Monad.Class.MonadTime (NominalDiffTime)
84+
import Control.Monad.Class.MonadTime qualified as Time
85+
import Control.Monad.Class.MonadTime.SI qualified as SI
8486
import Control.Monad.Class.MonadTimer.SI (TimeoutState (..))
8587

8688
import Control.Monad.IOSim.InternalTypes
87-
import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Trace (SimTrace))
89+
import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), Time (..),
90+
Trace (SimTrace))
8891
import Control.Monad.IOSim.Types (SimEvent)
8992
import Control.Monad.IOSimPOR.Timeout (unsafeTimeout)
9093
import Control.Monad.IOSimPOR.Types
@@ -186,7 +189,7 @@ data TimerCompletionInfo s =
186189
instance Hashable a => Hashable (Down a)
187190

188191
type RunQueue = HashPSQ (Down IOSimThreadId) (Down IOSimThreadId) ()
189-
type Timeouts s = IntPSQ Time (TimerCompletionInfo s)
192+
type Timeouts s = IntPSQ SI.Time (TimerCompletionInfo s)
190193

191194
-- | Internal state.
192195
--
@@ -196,7 +199,7 @@ data SimState s a = SimState {
196199
-- and blocked threads.
197200
threads :: !(Map IOSimThreadId (Thread s a)),
198201
-- | current time
199-
curTime :: !Time,
202+
curTime :: !SI.Time,
200203
-- | ordered list of timers and timeouts
201204
timers :: !(Timeouts s),
202205
-- | timeout locks in order to synchronize the timeout handler and the
@@ -221,7 +224,7 @@ initialState =
221224
SimState {
222225
runqueue = PSQ.empty,
223226
threads = Map.empty,
224-
curTime = Time 0,
227+
curTime = SI.Time 0,
225228
timers = IPSQ.empty,
226229
clocks = Map.singleton (ClockId []) epoch1970,
227230
nextVid = 0,
@@ -252,8 +255,8 @@ invariant Nothing SimState{runqueue,threads,clocks} =
252255

253256
-- | Interpret the simulation monotonic time as a 'NominalDiffTime' since
254257
-- the start.
255-
timeSinceEpoch :: Time -> NominalDiffTime
256-
timeSinceEpoch (Time t) = fromRational (toRational t)
258+
timeSinceEpoch :: SI.Time -> NominalDiffTime
259+
timeSinceEpoch (SI.Time t) = fromRational (toRational t)
257260

258261

259262
-- | Insert thread into `runqueue`.
@@ -457,15 +460,15 @@ schedule thread@Thread{
457460
GetWallTime k -> do
458461
let clockid = threadClockId thread
459462
clockoff = clocks Map.! clockid
460-
walltime = timeSinceEpoch time `addUTCTime` clockoff
463+
walltime = timeSinceEpoch time `Time.addUTCTime` clockoff
461464
thread' = thread { threadControl = ThreadControl (k walltime) ctl }
462465
schedule thread' simstate
463466

464467
SetWallTime walltime' k -> do
465468
let clockid = threadClockId thread
466469
clockoff = clocks Map.! clockid
467-
walltime = timeSinceEpoch time `addUTCTime` clockoff
468-
clockoff' = addUTCTime (diffUTCTime walltime' walltime) clockoff
470+
walltime = timeSinceEpoch time `Time.addUTCTime` clockoff
471+
clockoff' = (walltime' `Time.diffUTCTime` walltime) `Time.addUTCTime` clockoff
469472
thread' = thread { threadControl = ThreadControl k ctl }
470473
simstate' = simstate { clocks = Map.insert clockid clockoff' clocks }
471474
schedule thread' simstate'
@@ -1322,7 +1325,7 @@ removeMinimums = \psq -> coerce $
13221325
| p == p' -> collectAll (k:ks) p (x:xs) psq'
13231326
_ -> (reverse ks, p, reverse xs, psq)
13241327

1325-
traceMany :: [(Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]
1328+
traceMany :: [(SI.Time, IOSimThreadId, Int, Maybe ThreadLabel, SimEventType)]
13261329
-> SimTrace a -> SimTrace a
13271330
traceMany [] trace = trace
13281331
traceMany ((time, tid, tstep, tlbl, event):ts) trace =
@@ -1374,7 +1377,7 @@ controlSimTraceST limit control mainAction =
13741377
--
13751378

13761379
execAtomically :: forall s a c.
1377-
Time
1380+
SI.Time
13781381
-> IOSimThreadId
13791382
-> Maybe ThreadLabel
13801383
-> VarId

0 commit comments

Comments
 (0)