Skip to content

Commit a1dd35e

Browse files
bolt12coot
bolt12
authored and
coot
committed
Refactor IOSim primitives for register/threadDelay
1 parent e243439 commit a1dd35e

File tree

4 files changed

+122
-51
lines changed

4 files changed

+122
-51
lines changed

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -54,6 +54,9 @@ class Monad m => MonadDelay m where
5454
threadDelay d = void . atomically . awaitTimeout =<< newTimeout d
5555

5656
class (MonadSTM m, MonadDelay m) => MonadTimer m where
57+
-- | The type of the timeout handle, used with 'newTimeout', 'readTimeout',
58+
-- 'updateTimeout' and 'cancelTimeout'.
59+
--
5760
data Timeout m :: Type
5861

5962
-- | Create a new timeout which will fire at the given time duration in

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

Lines changed: 88 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -119,10 +119,13 @@ labelledThreads threadMap =
119119
[] threadMap
120120

121121

122-
-- | Timers mutable variables. First one supports 'newTimeout' api, the second
123-
-- one 'registerDelay'.
122+
-- | Timers mutable variables. Supports 'newTimeout' api, the second
123+
-- one 'registerDelay', the third one 'threadDelay'.
124124
--
125-
data TimerVars s = TimerVars !(TVar s TimeoutState) !(TVar s Bool)
125+
data TimerCompletionInfo s =
126+
Timer !(TVar s TimeoutState)
127+
| TimerRegisterDelay !(TVar s Bool)
128+
| TimerThreadDelay !ThreadId
126129

127130
-- | Internal state.
128131
--
@@ -136,7 +139,7 @@ data SimState s a = SimState {
136139
-- | current time
137140
curTime :: !Time,
138141
-- | ordered list of timers
139-
timers :: !(OrdPSQ TimeoutId Time (TimerVars s)),
142+
timers :: !(OrdPSQ TimeoutId Time (TimerCompletionInfo s)),
140143
-- | list of clocks
141144
clocks :: !(Map ClockId UTCTime),
142145
nextVid :: !TVarId, -- ^ next unused 'TVarId'
@@ -346,30 +349,72 @@ schedule !thread@Thread{
346349
NewTimeout d k ->
347350
{-# SCC "schedule.NewTimeout.2" #-} do
348351
!tvar <- execNewTVar nextVid
349-
(Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")
350-
TimeoutPending
351-
!tvar' <- execNewTVar (succ nextVid)
352-
(Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
353-
False
352+
(Just $ "<<timeout-state " ++ show (unTimeoutId nextTmid) ++ ">>")
353+
TimeoutPending
354354
let !expiry = d `addTime` time
355-
!t = Timeout tvar tvar' nextTmid
356-
!timers' = PSQ.insert nextTmid expiry (TimerVars tvar tvar') timers
355+
!t = Timeout tvar nextTmid
356+
!timers' = PSQ.insert nextTmid expiry (Timer tvar) timers
357357
!thread' = thread { threadControl = ThreadControl (k t) ctl }
358-
!trace <- schedule thread' simstate { timers = timers'
359-
, nextVid = succ (succ nextVid)
360-
, nextTmid = succ nextTmid }
358+
trace <- schedule thread' simstate { timers = timers'
359+
, nextVid = succ nextVid
360+
, nextTmid = succ nextTmid }
361361
return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace)
362362

363+
RegisterDelay d k | d < 0 ->
364+
{-# SCC "schedule.NewRegisterDelay" #-} do
365+
!tvar <- execNewTVar nextVid
366+
(Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
367+
True
368+
let !expiry = d `addTime` time
369+
!thread' = thread { threadControl = ThreadControl (k tvar) ctl }
370+
trace <- schedule thread' simstate { nextVid = succ nextVid }
371+
return (SimTrace time tid tlbl (EventRegisterDelayCreated nextTmid nextVid expiry) $
372+
SimTrace time tid tlbl (EventRegisterDelayFired nextTmid) $
373+
trace)
374+
375+
RegisterDelay d k ->
376+
{-# SCC "schedule.NewRegisterDelay" #-} do
377+
!tvar <- execNewTVar nextVid
378+
(Just $ "<<timeout " ++ show (unTimeoutId nextTmid) ++ ">>")
379+
False
380+
let !expiry = d `addTime` time
381+
!timers' = PSQ.insert nextTmid expiry (TimerRegisterDelay tvar) timers
382+
!thread' = thread { threadControl = ThreadControl (k tvar) ctl }
383+
trace <- schedule thread' simstate { timers = timers'
384+
, nextVid = succ nextVid
385+
, nextTmid = succ nextTmid }
386+
return (SimTrace time tid tlbl
387+
(EventRegisterDelayCreated nextTmid nextVid expiry) trace)
388+
389+
ThreadDelay d k | d < 0 ->
390+
{-# SCC "schedule.NewThreadDelay" #-} do
391+
let !expiry = d `addTime` time
392+
!thread' = thread { threadControl = ThreadControl k ctl }
393+
trace <- schedule thread' simstate
394+
return (SimTrace time tid tlbl (EventThreadDelay expiry) $
395+
SimTrace time tid tlbl EventThreadDelayFired $
396+
trace)
397+
398+
ThreadDelay d k ->
399+
{-# SCC "schedule.NewThreadDelay" #-} do
400+
let !expiry = d `addTime` time
401+
!timers' = PSQ.insert nextTmid expiry (TimerThreadDelay tid) timers
402+
!thread' = thread { threadControl = ThreadControl k ctl }
403+
!trace <- deschedule Blocked thread' simstate { timers = timers'
404+
, nextTmid = succ nextTmid }
405+
return (SimTrace time tid tlbl (EventThreadDelay expiry) trace)
406+
407+
363408
-- we do not follow `GHC.Event` behaviour here; updating a timer to the past
364409
-- effectively cancels it.
365-
UpdateTimeout (Timeout _tvar _tvar' tmid) d k | d < 0 ->
410+
UpdateTimeout (Timeout _tvar tmid) d k | d < 0 ->
366411
{-# SCC "schedule.UpdateTimeout" #-} do
367412
let !timers' = PSQ.delete tmid timers
368413
!thread' = thread { threadControl = ThreadControl k ctl }
369414
trace <- schedule thread' simstate { timers = timers' }
370415
return (SimTrace time tid tlbl (EventTimerCancelled tmid) trace)
371416

372-
UpdateTimeout (Timeout _tvar _tvar' tmid) d k ->
417+
UpdateTimeout (Timeout _tvar tmid) d k ->
373418
{-# SCC "schedule.UpdateTimeout" #-} do
374419
-- updating an expired timeout is a noop, so it is safe
375420
-- to race using a timeout with updating or cancelling it
@@ -387,12 +432,12 @@ schedule !thread@Thread{
387432
let thread' = thread { threadControl = ThreadControl k ctl }
388433
schedule thread' simstate
389434

390-
CancelTimeout (Timeout tvar _tvar' tmid) k ->
435+
CancelTimeout (Timeout tvar tmid) k ->
391436
{-# SCC "schedule.CancelTimeout" #-} do
392437
let !timers' = PSQ.delete tmid timers
393438
!thread' = thread { threadControl = ThreadControl k ctl }
394439
!written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)
395-
(!wakeup, wokeby) <- threadsUnblockedByWrites written
440+
(wakeup, wokeby) <- threadsUnblockedByWrites written
396441
mapM_ (\(SomeTVar var) -> unblockAllThreadsFromTVar var) written
397442
let (unblocked,
398443
simstate') = unblockThreads wakeup simstate
@@ -525,7 +570,7 @@ schedule !thread@Thread{
525570
(runIOSim action')
526571
(MaskFrame k maskst ctl)
527572
, threadMasking = maskst' }
528-
!trace <-
573+
trace <-
529574
case maskst' of
530575
-- If we're now unmasked then check for any pending async exceptions
531576
Unmasked -> SimTrace time tid tlbl (EventDeschedule Interruptable)
@@ -723,30 +768,43 @@ reschedule !simstate@SimState{ threads, timers, curTime = time } =
723768

724769
-- Reuse the STM functionality here to write all the timer TVars.
725770
-- Simplify to a special case that only reads and writes TVars.
726-
!written <- execAtomically' (runSTM $ mapM_ timeoutAction fired)
727-
(wakeup, wokeby) <- threadsUnblockedByWrites written
771+
!written <- execAtomically' (runSTM $ mapM_ timeoutSTMAction fired)
772+
(wakeupSTM, wokeby) <- threadsUnblockedByWrites written
728773
!_ <- mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written
729774

730-
let (unblocked,
731-
simstate') = unblockThreads wakeup simstate
775+
-- Check all fired threadDelays
776+
let wakeupThreadDelay = [ tid | TimerThreadDelay tid <- fired ]
777+
wakeup = wakeupThreadDelay ++ wakeupSTM
778+
(_, !simstate') = unblockThreads wakeup simstate
779+
732780
!trace <- reschedule simstate' { curTime = time'
733781
, timers = timers' }
734782
return $
735-
traceMany ([ (time', ThreadId [-1], Just "timer", EventTimerExpired tmid)
736-
| tmid <- tmids ]
783+
traceMany ([ ( time', ThreadId [-1], Just "timer"
784+
, EventTimerFired tmid)
785+
| (tmid, Timer _) <- zip tmids fired ]
786+
++ [ ( time', ThreadId [-1], Just "register delay timer"
787+
, EventRegisterDelayFired tmid)
788+
| (tmid, TimerRegisterDelay _) <- zip tmids fired ]
737789
++ [ (time', tid', tlbl', EventTxWakeup vids)
738-
| tid' <- unblocked
790+
| tid' <- wakeupSTM
739791
, let tlbl' = lookupThreadLabel tid' threads
740-
, let Just vids = Set.toList <$> Map.lookup tid' wokeby ])
792+
, let Just vids = Set.toList <$> Map.lookup tid' wokeby ]
793+
++ [ ( time', tid, Just "thread delay timer"
794+
, EventThreadDelayFired)
795+
| tid <- wakeupThreadDelay ])
741796
trace
742797
where
743-
timeoutAction (TimerVars var bvar) = do
798+
timeoutSTMAction (Timer var) = do
744799
x <- readTVar var
745800
case x of
746-
TimeoutPending -> writeTVar var TimeoutFired
747-
>> writeTVar bvar True
801+
TimeoutPending -> writeTVar var TimeoutFired
748802
TimeoutFired -> error "MonadTimer(Sim): invariant violation"
749803
TimeoutCancelled -> return ()
804+
timeoutSTMAction (TimerRegisterDelay var) = writeTVar var True
805+
-- Note that 'threadDelay' is not handled via STM style wakeup, but rather
806+
-- it's handled directly above with 'wakeupThreadDelay' and 'unblockThreads'
807+
timeoutSTMAction (TimerThreadDelay _) = return ()
750808

751809
unblockThreads :: [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
752810
unblockThreads !wakeup !simstate@SimState {runqueue, threads} =

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

Lines changed: 25 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -150,9 +150,13 @@ data SimA s a where
150150
SetWallTime :: UTCTime -> SimA s b -> SimA s b
151151
UnshareClock :: SimA s b -> SimA s b
152152

153-
NewTimeout :: DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
154-
UpdateTimeout:: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
155-
CancelTimeout:: Timeout (IOSim s) -> SimA s b -> SimA s b
153+
RegisterDelay :: DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b
154+
155+
ThreadDelay :: DiffTime -> SimA s b -> SimA s b
156+
157+
NewTimeout :: DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
158+
UpdateTimeout :: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
159+
CancelTimeout :: Timeout (IOSim s) -> SimA s b -> SimA s b
156160

157161
Throw :: Thrower -> SomeException -> SimA s a
158162
Catch :: Exception e =>
@@ -542,17 +546,17 @@ unshareClock :: IOSim s ()
542546
unshareClock = IOSim $ oneShot $ \k -> UnshareClock (k ())
543547

544548
instance MonadDelay (IOSim s) where
545-
-- Use default in terms of MonadTimer
549+
-- Use optimized IOSim primitive
550+
threadDelay d = IOSim $ oneShot $ \k -> ThreadDelay d (k ())
546551

547552
instance MonadTimer (IOSim s) where
548-
data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !(TVar s Bool) !TimeoutId
549-
-- ^ a timeout; we keep both 'TVar's to support
550-
-- `newTimer` and 'registerTimeout'.
553+
data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !TimeoutId
554+
-- ^ a timeout
551555
| NegativeTimeout !TimeoutId
552556
-- ^ a negative timeout
553557

554-
readTimeout (Timeout var _bvar _key) = MonadSTM.readTVar var
555-
readTimeout (NegativeTimeout _key) = pure TimeoutCancelled
558+
readTimeout (Timeout var _key) = MonadSTM.readTVar var
559+
readTimeout (NegativeTimeout _key) = pure TimeoutCancelled
556560

557561
newTimeout d = IOSim $ oneShot $ \k -> NewTimeout d k
558562
updateTimeout t d = IOSim $ oneShot $ \k -> UpdateTimeout t d (k ())
@@ -563,7 +567,7 @@ instance MonadTimer (IOSim s) where
563567
| d == 0 = return Nothing
564568
| otherwise = do
565569
pid <- myThreadId
566-
t@(Timeout _ _ tid) <- newTimeout d
570+
t@(Timeout _ tid) <- newTimeout d
567571
handleJust
568572
(\(TimeoutException tid') -> if tid' == tid
569573
then Just ()
@@ -579,7 +583,7 @@ instance MonadTimer (IOSim s) where
579583
throwTo pid' AsyncCancelled)
580584
(\_ -> Just <$> action)
581585

582-
registerDelay d = IOSim $ oneShot $ \k -> NewTimeout d (\(Timeout _var bvar _) -> k bvar)
586+
registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d k
583587

584588
newtype TimeoutException = TimeoutException TimeoutId deriving Eq
585589

@@ -806,10 +810,16 @@ data SimEventType
806810
(Maybe Effect) -- effect performed (only for `IOSimPOR`)
807811
| EventTxWakeup [Labelled TVarId] -- changed vars causing retry
808812

809-
| EventTimerCreated TimeoutId TVarId Time
810-
| EventTimerUpdated TimeoutId Time
811-
| EventTimerCancelled TimeoutId
812-
| EventTimerExpired TimeoutId
813+
| EventThreadDelay Time
814+
| EventThreadDelayFired
815+
816+
| EventRegisterDelayCreated TimeoutId TVarId Time
817+
| EventRegisterDelayFired TimeoutId
818+
819+
| EventTimerCreated TimeoutId TVarId Time
820+
| EventTimerUpdated TimeoutId Time
821+
| EventTimerCancelled TimeoutId
822+
| EventTimerFired TimeoutId
813823

814824
-- the following events are inserted to mark the difference between
815825
-- a failed trace and a similar passing trace of the same action

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

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@
1616
{-# LANGUAGE StandaloneDeriving #-}
1717
{-# LANGUAGE TypeApplications #-}
1818
{-# LANGUAGE TypeFamilies #-}
19+
{-# LANGUAGE StandaloneDeriving #-}
1920

2021
{-# OPTIONS_GHC -Wno-orphans #-}
2122
-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')
@@ -456,7 +457,7 @@ schedule thread@Thread{
456457
False
457458
modifySTRef (tvarVClock tvar') (leastUpperBoundVClock vClock)
458459
let expiry = d `addTime` time
459-
t = Timeout tvar tvar' nextTmid
460+
t = Timeout tvar nextTmid
460461
timers' = PSQ.insert nextTmid expiry (TimerVars tvar tvar') timers
461462
thread' = thread { threadControl = ThreadControl (k t) ctl }
462463
!trace <- schedule thread' simstate { timers = timers'
@@ -466,13 +467,13 @@ schedule thread@Thread{
466467

467468
-- we do not follow `GHC.Event` behaviour here; updating a timer to the past
468469
-- effectively cancels it.
469-
UpdateTimeout (Timeout _tvar _tvar' tmid) d k | d < 0 -> do
470+
UpdateTimeout (Timeout _tvar tmid) d k | d < 0 -> do
470471
let timers' = PSQ.delete tmid timers
471472
thread' = thread { threadControl = ThreadControl k ctl }
472473
trace <- schedule thread' simstate { timers = timers' }
473474
return (SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid) trace)
474475

475-
UpdateTimeout (Timeout _tvar _tvar' tmid) d k -> do
476+
UpdateTimeout (Timeout _tvar tmid) d k -> do
476477
-- updating an expired timeout is a noop, so it is safe
477478
-- to race using a timeout with updating or cancelling it
478479
let updateTimeout_ Nothing = ((), Nothing)
@@ -488,7 +489,7 @@ schedule thread@Thread{
488489
let thread' = thread { threadControl = ThreadControl k ctl }
489490
schedule thread' simstate
490491

491-
CancelTimeout (Timeout tvar tvar' tmid) k -> do
492+
CancelTimeout (Timeout tvar tmid) k -> do
492493
let timers' = PSQ.delete tmid timers
493494
written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled)
494495
(wakeup, wokeby) <- threadsUnblockedByWrites written
@@ -503,7 +504,6 @@ schedule thread@Thread{
503504
(unblocked,
504505
simstate') = unblockThreads vClock wakeup simstate
505506
modifySTRef (tvarVClock tvar) (leastUpperBoundVClock vClock)
506-
modifySTRef (tvarVClock tvar') (leastUpperBoundVClock vClock)
507507
!trace <- deschedule Yield thread' simstate' { timers = timers' }
508508
return $ SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid)
509509
$ traceMany
@@ -946,7 +946,7 @@ reschedule simstate@SimState{ threads, timers, curTime = time, races } =
946946
!trace <- reschedule simstate'' { curTime = time'
947947
, timers = timers' }
948948
let traceEntries =
949-
[ (time', ThreadId [-1], (-1), Just "timer", EventTimerExpired tmid)
949+
[ (time', ThreadId [-1], (-1), Just "timer", EventTimerFired tmid)
950950
| tmid <- tmids ]
951951
++ [ (time', tid', (-1), tlbl', EventTxWakeup vids)
952952
| tid' <- unblocked

0 commit comments

Comments
 (0)