{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE DerivingVia               #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTSyntax                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')
-- and 'reschedule'.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Control.Monad.IOSim.Internal
  ( IOSim (..)
  , runIOSim
  , runSimTraceST
  , traceM
  , traceSTM
  , STM
  , STMSim
  , setCurrentTime
  , unshareClock
  , TimeoutException (..)
  , EventlogEvent (..)
  , EventlogMarker (..)
  , ThreadId
  , ThreadLabel
  , Labelled (..)
  , SimTrace
  , Trace.Trace (SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock)
  , SimEvent (..)
  , SimResult (..)
  , SimEventType (..)
  , ppTrace
  , ppTrace_
  , ppSimEvent
  , liftST
  , execReadTVar
  ) where

import           Prelude hiding (read)

import           Data.Dynamic
import           Data.Foldable (foldlM, toList, traverse_)
import qualified Data.List as List
import qualified Data.List.Trace as Trace
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (mapMaybe)
import           Data.OrdPSQ (OrdPSQ)
import qualified Data.OrdPSQ as PSQ
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Time (UTCTime (..), fromGregorian)
import           Data.Deque.Strict (Deque)
import qualified Data.Deque.Strict as Deque

import           Control.Exception (NonTermination (..), assert, throw)
import           Control.Monad (join, when)
import           Control.Monad.ST.Lazy
import           Control.Monad.ST.Lazy.Unsafe (unsafeIOToST, unsafeInterleaveST)
import           Data.STRef.Lazy

import           Control.Concurrent.Class.MonadSTM.TMVar
import           Control.Concurrent.Class.MonadSTM.TVar hiding (TVar)
import           Control.Monad.Class.MonadFork (killThread, myThreadId, throwTo)
import           Control.Monad.Class.MonadSTM hiding (STM)
import           Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar))
import           Control.Monad.Class.MonadThrow hiding (getMaskingState)
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer.SI (TimeoutState (..))

import           Control.Monad.IOSim.InternalTypes
import           Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent),
                     Trace (SimPORTrace))
import           Control.Monad.IOSim.Types (SimEvent)

--
-- Simulation interpreter
--

data Thread s a = Thread {
    forall s a. Thread s a -> ThreadId
threadId      :: !ThreadId,
    forall s a. Thread s a -> ThreadControl s a
threadControl :: !(ThreadControl s a),
    forall s a. Thread s a -> ThreadStatus
threadStatus  :: !ThreadStatus,
    forall s a. Thread s a -> MaskingState
threadMasking :: !MaskingState,
    -- other threads blocked in a ThrowTo to us because we are or were masked
    forall s a. Thread s a -> [(SomeException, Labelled ThreadId)]
threadThrowTo :: ![(SomeException, Labelled ThreadId)],
    forall s a. Thread s a -> ClockId
threadClockId :: !ClockId,
    forall s a. Thread s a -> Maybe ThreadLabel
threadLabel   ::  Maybe ThreadLabel,
    forall s a. Thread s a -> Int
threadNextTId :: !Int
  }

isThreadBlocked :: Thread s a -> Bool
isThreadBlocked :: forall s a. Thread s a -> Bool
isThreadBlocked Thread s a
t = case forall s a. Thread s a -> ThreadStatus
threadStatus Thread s a
t of
    ThreadBlocked {} -> Bool
True
    ThreadStatus
_                -> Bool
False

labelledTVarId :: TVar s a -> ST s (Labelled TVarId)
labelledTVarId :: forall s a. TVar s a -> ST s (Labelled TVarId)
labelledTVarId TVar { TVarId
tvarId :: forall s a. TVar s a -> TVarId
tvarId :: TVarId
tvarId, STRef s (Maybe ThreadLabel)
tvarLabel :: forall s a. TVar s a -> STRef s (Maybe ThreadLabel)
tvarLabel :: STRef s (Maybe ThreadLabel)
tvarLabel } = (forall a. a -> Maybe ThreadLabel -> Labelled a
Labelled TVarId
tvarId) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. STRef s a -> ST s a
readSTRef STRef s (Maybe ThreadLabel)
tvarLabel

labelledThreads :: Map ThreadId (Thread s a) -> [Labelled ThreadId]
labelledThreads :: forall s a. Map ThreadId (Thread s a) -> [Labelled ThreadId]
labelledThreads Map ThreadId (Thread s a)
threadMap =
    -- @Map.foldr'@ (and alikes) are not strict enough, to not ratain the
    -- original thread map we need to evaluate the spine of the list.
    -- TODO: https://github.com/haskell/containers/issues/749
    forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr'
      (\Thread { ThreadId
threadId :: ThreadId
threadId :: forall s a. Thread s a -> ThreadId
threadId, Maybe ThreadLabel
threadLabel :: Maybe ThreadLabel
threadLabel :: forall s a. Thread s a -> Maybe ThreadLabel
threadLabel } ![Labelled ThreadId]
acc -> forall a. a -> Maybe ThreadLabel -> Labelled a
Labelled ThreadId
threadId Maybe ThreadLabel
threadLabel forall a. a -> [a] -> [a]
: [Labelled ThreadId]
acc)
      [] Map ThreadId (Thread s a)
threadMap


-- | Timers mutable variables. Supports 'newTimeout' api, the second
-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one
-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'.
--
data TimerCompletionInfo s =
       Timer !(TVar s TimeoutState)
     -- ^ `newTimeout` timer.
     | TimerRegisterDelay !(TVar s Bool)
     -- ^ `registerDelay` timer.
     | TimerThreadDelay !ThreadId !TimeoutId
     -- ^ `threadDelay` timer run by `ThreadId` which was assigned the given
     -- `TimeoutId` (only used to report in a trace).
     | TimerTimeout !ThreadId !TimeoutId !(TMVar (IOSim s) ThreadId)
     -- ^ `timeout` timer run by `ThreadId` which was assigned the given
     -- `TimeoutId` (only used to report in a trace).


type Timeouts s = OrdPSQ TimeoutId Time (TimerCompletionInfo s)

-- | Internal state.
--
data SimState s a = SimState {
       forall s a. SimState s a -> Deque ThreadId
runqueue :: !(Deque ThreadId),
       -- | All threads other than the currently running thread: both running
       -- and blocked threads.
       forall s a. SimState s a -> Map ThreadId (Thread s a)
threads  :: !(Map ThreadId (Thread s a)),
       -- | current time
       forall s a. SimState s a -> Time
curTime  :: !Time,
       -- | ordered list of timers and timeouts
       forall s a. SimState s a -> Timeouts s
timers   :: !(Timeouts s),
       -- | list of clocks
       forall s a. SimState s a -> Map ClockId UTCTime
clocks   :: !(Map ClockId UTCTime),
       forall s a. SimState s a -> TVarId
nextVid  :: !TVarId,     -- ^ next unused 'TVarId'
       forall s a. SimState s a -> TimeoutId
nextTmid :: !TimeoutId   -- ^ next unused 'TimeoutId'
     }

initialState :: SimState s a
initialState :: forall s a. SimState s a
initialState =
    SimState {
      runqueue :: Deque ThreadId
runqueue = forall a. Monoid a => a
mempty,
      threads :: Map ThreadId (Thread s a)
threads  = forall k a. Map k a
Map.empty,
      curTime :: Time
curTime  = DiffTime -> Time
Time DiffTime
0,
      timers :: Timeouts s
timers   = forall k p v. OrdPSQ k p v
PSQ.empty,
      clocks :: Map ClockId UTCTime
clocks   = forall k a. k -> a -> Map k a
Map.singleton ([Int] -> ClockId
ClockId []) UTCTime
epoch1970,
      nextVid :: TVarId
nextVid  = Int -> TVarId
TVarId Int
0,
      nextTmid :: TimeoutId
nextTmid = Int -> TimeoutId
TimeoutId Int
0
    }
  where
    epoch1970 :: UTCTime
epoch1970 = Day -> DiffTime -> UTCTime
UTCTime (Year -> Int -> Int -> Day
fromGregorian Year
1970 Int
1 Int
1) DiffTime
0

invariant :: Maybe (Thread s a) -> SimState s a -> x -> x

invariant :: forall s a x. Maybe (Thread s a) -> SimState s a -> x -> x
invariant (Just Thread s a
running) simstate :: SimState s a
simstate@SimState{Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue,Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads,Map ClockId UTCTime
clocks :: Map ClockId UTCTime
clocks :: forall s a. SimState s a -> Map ClockId UTCTime
clocks} =
   forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (forall s a. Thread s a -> Bool
isThreadBlocked Thread s a
running))
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall s a. Thread s a -> ThreadId
threadId Thread s a
running forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map ThreadId (Thread s a)
threads)
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall s a. Thread s a -> ThreadId
threadId Thread s a
running forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.notElem` Deque ThreadId
runqueue)
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall s a. Thread s a -> ClockId
threadClockId Thread s a
running forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ClockId UTCTime
clocks)
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a x. Maybe (Thread s a) -> SimState s a -> x -> x
invariant forall a. Maybe a
Nothing SimState s a
simstate

invariant Maybe (Thread s a)
Nothing SimState{Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue,Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads,Map ClockId UTCTime
clocks :: Map ClockId UTCTime
clocks :: forall s a. SimState s a -> Map ClockId UTCTime
clocks} =
   forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ThreadId (Thread s a)
threads) Deque ThreadId
runqueue)
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ forall s a. Thread s a -> Bool
isThreadBlocked Thread s a
t forall a. Eq a => a -> a -> Bool
== (forall s a. Thread s a -> ThreadId
threadId Thread s a
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Deque ThreadId
runqueue)
               | Thread s a
t <- forall k a. Map k a -> [a]
Map.elems Map ThreadId (Thread s a)
threads ])
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Deque ThreadId
runqueue forall a. Eq a => a -> a -> Bool
== forall a. Eq a => [a] -> [a]
List.nub (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Deque ThreadId
runqueue))
 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ forall s a. Thread s a -> ClockId
threadClockId Thread s a
t forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ClockId UTCTime
clocks
               | Thread s a
t <- forall k a. Map k a -> [a]
Map.elems Map ThreadId (Thread s a)
threads ])

-- | Interpret the simulation monotonic time as a 'NominalDiffTime' since
-- the start.
timeSinceEpoch :: Time -> NominalDiffTime
timeSinceEpoch :: Time -> NominalDiffTime
timeSinceEpoch (Time DiffTime
t) = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational DiffTime
t)


-- | Schedule / run a thread.
--
schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule :: forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule !thread :: Thread s a
thread@Thread{
           threadId :: forall s a. Thread s a -> ThreadId
threadId      = ThreadId
tid,
           threadControl :: forall s a. Thread s a -> ThreadControl s a
threadControl = ThreadControl SimA s b
action ControlStack s b a
ctl,
           threadMasking :: forall s a. Thread s a -> MaskingState
threadMasking = MaskingState
maskst,
           threadLabel :: forall s a. Thread s a -> Maybe ThreadLabel
threadLabel   = Maybe ThreadLabel
tlbl
         }
         !simstate :: SimState s a
simstate@SimState {
           Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue,
           Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads,
           Timeouts s
timers :: Timeouts s
timers :: forall s a. SimState s a -> Timeouts s
timers,
           Map ClockId UTCTime
clocks :: Map ClockId UTCTime
clocks :: forall s a. SimState s a -> Map ClockId UTCTime
clocks,
           TVarId
nextVid :: TVarId
nextVid :: forall s a. SimState s a -> TVarId
nextVid, TimeoutId
nextTmid :: TimeoutId
nextTmid :: forall s a. SimState s a -> TimeoutId
nextTmid,
           curTime :: forall s a. SimState s a -> Time
curTime  = Time
time
         } =
  forall s a x. Maybe (Thread s a) -> SimState s a -> x -> x
invariant (forall a. a -> Maybe a
Just Thread s a
thread) SimState s a
simstate forall a b. (a -> b) -> a -> b
$
  case SimA s b
action of

    Return b
x -> {-# SCC "schedule.Return" #-}
                case ControlStack s b a
ctl of
      ControlStack s b a
MainFrame ->
        -- the main thread is done, so we're done
        -- even if other threads are still running
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl SimEventType
EventThreadFinished
               forall a b. (a -> b) -> a -> b
$ forall a. Time -> a -> [Labelled ThreadId] -> SimTrace a
TraceMainReturn Time
time b
x (forall s a. Map ThreadId (Thread s a) -> [Labelled ThreadId]
labelledThreads Map ThreadId (Thread s a)
threads)

      ControlStack s b a
ForkFrame -> do
        -- this thread is done
        !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Terminated Thread s a
thread SimState s a
simstate
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl SimEventType
EventThreadFinished
               forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule Deschedule
Terminated)
               forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

      MaskFrame b -> SimA s c
k MaskingState
maskst' ControlStack s c a
ctl' -> do
        -- pop the control stack, restore thread-local state
        let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (b -> SimA s c
k b
x) ControlStack s c a
ctl'
                             , threadMasking :: MaskingState
threadMasking = MaskingState
maskst' }
        -- but if we're now unmasked, check for any pending async exceptions
        !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Interruptable Thread s a
thread' SimState s a
simstate
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (MaskingState -> SimEventType
EventMask MaskingState
maskst')
               forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule Deschedule
Interruptable)
               forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

      CatchFrame e -> SimA s b
_handler b -> SimA s c
k ControlStack s c a
ctl' -> do
        -- pop the control stack and continue
        let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (b -> SimA s c
k b
x) ControlStack s c a
ctl' }
        forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

      TimeoutFrame TimeoutId
tmid TMVar (IOSim s) ThreadId
lock Maybe b -> SimA s c
k ControlStack s c a
ctl' -> do
        -- There is a possible race between timeout action and the timeout expiration.
        -- We use a lock to solve the race.

        -- We cannot do `tryPutMVar` in the `treadAction`, because we need to
        -- know if the `lock` is empty right now when we still have the frame.
        Bool
v <- forall s a. TMVar (IOSim s) a -> a -> ST s Bool
execTryPutTMVar TMVar (IOSim s) ThreadId
lock forall a. (?callStack::CallStack) => a
undefined
        let -- Kill the assassin throwing thread then unmask exceptions and
            -- carry on the continuation
            threadAction :: IOSim s ()
            threadAction :: IOSim s ()
threadAction =
              if Bool
v then forall s. TimeoutId -> IOSim s ()
unsafeUnregisterTimeout TimeoutId
tmid
                   else forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar (IOSim s) ThreadId
lock) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFork m => ThreadId m -> m ()
killThread

            thread' :: Thread s a
thread' =
              Thread s a
thread { threadControl :: ThreadControl s a
threadControl =
                        forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (case IOSim s ()
threadAction of
                                        IOSim forall r. (() -> SimA s r) -> SimA s r
k' -> forall r. (() -> SimA s r) -> SimA s r
k' (\() -> Maybe b -> SimA s c
k (forall a. a -> Maybe a
Just b
x)))
                                      ControlStack s c a
ctl'
                     }
        forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

      DelayFrame TimeoutId
tmid SimA s c
k ControlStack s c a
ctl' -> do
        let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s c
k ControlStack s c a
ctl' }
            timers' :: Timeouts s
timers' = forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid Timeouts s
timers
        forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers = Timeouts s
timers' }

    Throw SomeException
e -> {-# SCC "schedule.Throw" #-}
               case forall s a.
SomeException
-> Thread s a
-> Timeouts s
-> (Either Bool (Thread s a), Timeouts s)
unwindControlStack SomeException
e Thread s a
thread Timeouts s
timers of
      -- Found a CatchFrame
      (Right thread' :: Thread s a
thread'@Thread { threadMasking :: forall s a. Thread s a -> MaskingState
threadMasking = MaskingState
maskst' }, Timeouts s
timers'') -> do
        -- We found a suitable exception handler, continue with that
        SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers = Timeouts s
timers'' }
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> SimEventType
EventThrow SomeException
e) forall a b. (a -> b) -> a -> b
$
                forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (MaskingState -> SimEventType
EventMask MaskingState
maskst') SimTrace a
trace)

      (Left Bool
isMain, Timeouts s
timers'')
        -- We unwound and did not find any suitable exception handler, so we
        -- have an unhandled exception at the top level of the thread.
        | Bool
isMain ->
          -- An unhandled exception in the main thread terminates the program
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> SimEventType
EventThrow SomeException
e) forall a b. (a -> b) -> a -> b
$
                  forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> SimEventType
EventThreadUnhandled SomeException
e) forall a b. (a -> b) -> a -> b
$
                  forall a.
Time -> SomeException -> [Labelled ThreadId] -> SimTrace a
TraceMainException Time
time SomeException
e (forall s a. Map ThreadId (Thread s a) -> [Labelled ThreadId]
labelledThreads Map ThreadId (Thread s a)
threads))

        | Bool
otherwise -> do
          -- An unhandled exception in any other thread terminates the thread
          !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Terminated Thread s a
thread SimState s a
simstate { timers :: Timeouts s
timers = Timeouts s
timers'' }
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> SimEventType
EventThrow SomeException
e)
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> SimEventType
EventThreadUnhandled SomeException
e)
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule Deschedule
Terminated)
                 forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

    Catch SimA s a
action' e -> SimA s a
handler a -> SimA s b
k ->
      {-# SCC "schedule.Catch" #-} do
      -- push the failure and success continuations onto the control stack
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s a
action'
                                               (forall a s b c a.
Exception a =>
(a -> SimA s b)
-> (b -> SimA s c) -> ControlStack s c a -> ControlStack s b a
CatchFrame e -> SimA s a
handler a -> SimA s b
k ControlStack s b a
ctl) }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    Evaluate a
expr a -> SimA s b
k ->
      {-# SCC "schedule.Evaulate" #-} do
      Either SomeException a
mbWHNF <- forall a s. IO a -> ST s a
unsafeIOToST forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate a
expr
      case Either SomeException a
mbWHNF of
        Left SomeException
e -> do
          -- schedule this thread to immediately raise the exception
          let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl }
          forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate
        Right a
whnf -> do
          -- continue with the resulting WHNF
          let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
whnf) ControlStack s b a
ctl }
          forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    Say ThreadLabel
msg SimA s b
k ->
      {-# SCC "schedule.Say" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (ThreadLabel -> SimEventType
EventSay ThreadLabel
msg) SimTrace a
trace)

    Output Dynamic
x SimA s b
k ->
      {-# SCC "schedule.Output" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Dynamic -> SimEventType
EventLog Dynamic
x) SimTrace a
trace)

    LiftST ST s a
st a -> SimA s b
k ->
      {-# SCC "schedule.LiftST" #-} do
      a
x <- forall s a. ST s a -> ST s a
strictToLazyST ST s a
st
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    GetMonoTime Time -> SimA s b
k ->
      {-# SCC "schedule.GetMonoTime" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (Time -> SimA s b
k Time
time) ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    GetWallTime UTCTime -> SimA s b
k ->
      {-# SCC "schedule.GetWallTime" #-} do
      let !clockid :: ClockId
clockid  = forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
          !clockoff :: UTCTime
clockoff = Map ClockId UTCTime
clocks forall k a. Ord k => Map k a -> k -> a
Map.! ClockId
clockid
          !walltime :: UTCTime
walltime = Time -> NominalDiffTime
timeSinceEpoch Time
time NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
clockoff
          !thread' :: Thread s a
thread'  = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (UTCTime -> SimA s b
k UTCTime
walltime) ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    SetWallTime UTCTime
walltime' SimA s b
k ->
      {-# SCC "schedule.SetWallTime" #-} do
      let !clockid :: ClockId
clockid   = forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
          !clockoff :: UTCTime
clockoff  = Map ClockId UTCTime
clocks forall k a. Ord k => Map k a -> k -> a
Map.! ClockId
clockid
          !walltime :: UTCTime
walltime  = Time -> NominalDiffTime
timeSinceEpoch Time
time NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
clockoff
          !clockoff' :: UTCTime
clockoff' = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
walltime' UTCTime
walltime) UTCTime
clockoff
          !thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
          !simstate' :: SimState s a
simstate' = SimState s a
simstate { clocks :: Map ClockId UTCTime
clocks = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ClockId
clockid UTCTime
clockoff' Map ClockId UTCTime
clocks }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate'

    UnshareClock SimA s b
k ->
      {-# SCC "schedule.UnshareClock" #-} do
      let !clockid :: ClockId
clockid   = forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
          !clockoff :: UTCTime
clockoff  = Map ClockId UTCTime
clocks forall k a. Ord k => Map k a -> k -> a
Map.! ClockId
clockid
          !clockid' :: ClockId
clockid'  = let ThreadId [Int]
i = ThreadId
tid in [Int] -> ClockId
ClockId [Int]
i -- reuse the thread id
          !thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl
                              , threadClockId :: ClockId
threadClockId = ClockId
clockid' }
          !simstate' :: SimState s a
simstate' = SimState s a
simstate { clocks :: Map ClockId UTCTime
clocks = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ClockId
clockid' UTCTime
clockoff Map ClockId UTCTime
clocks }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate'

    -- This case is guarded by checks in 'timeout' itself.
    StartTimeout DiffTime
d SimA s a
_ Maybe a -> SimA s b
_ | DiffTime
d forall a. Ord a => a -> a -> Bool
<= DiffTime
0 ->
      forall a. (?callStack::CallStack) => ThreadLabel -> a
error ThreadLabel
"schedule: StartTimeout: Impossible happened"

    StartTimeout DiffTime
d SimA s a
action' Maybe a -> SimA s b
k ->
      {-# SCC "schedule.StartTimeout" #-} do
      TMVarDefault (IOSim s) ThreadId
lock <- forall (m :: * -> *) a. TVar m (Maybe a) -> TMVarDefault m a
TMVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ThreadLabel
"lock-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ThreadLabel
show TimeoutId
nextTmid) forall a. Maybe a
Nothing
      let !expiry :: Time
expiry    = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !timers' :: Timeouts s
timers'   = forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert TimeoutId
nextTmid Time
expiry (forall s.
ThreadId
-> TimeoutId -> TMVar (IOSim s) ThreadId -> TimerCompletionInfo s
TimerTimeout ThreadId
tid TimeoutId
nextTmid TMVarDefault (IOSim s) ThreadId
lock) Timeouts s
timers
          !thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl =
                                 forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s a
action'
                                               (forall s b a a.
TimeoutId
-> TMVar (IOSim s) ThreadId
-> (Maybe b -> SimA s a)
-> ControlStack s a a
-> ControlStack s b a
TimeoutFrame TimeoutId
nextTmid TMVarDefault (IOSim s) ThreadId
lock Maybe a -> SimA s b
k ControlStack s b a
ctl)
                              }
      !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Yield Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers   = Timeouts s
timers'
                                                  , nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid
                                                  , nextVid :: TVarId
nextVid  = forall a. Enum a => a -> a
succ TVarId
nextVid
                                                  }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> ThreadId -> Time -> SimEventType
EventTimeoutCreated TimeoutId
nextTmid ThreadId
tid Time
expiry) SimTrace a
trace)

    UnregisterTimeout TimeoutId
tmid SimA s b
k ->
      {-# SCC "schedule.UnregisterTimeout" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers = forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid Timeouts s
timers }

    RegisterDelay DiffTime
d TVar s Bool -> SimA s b
k | DiffTime
d forall a. Ord a => a -> a -> Bool
< DiffTime
0 ->
      {-# SCC "schedule.NewRegisterDelay.1" #-} do
      !TVar s Bool
tvar <- forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid
                          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ThreadLabel
"<<timeout " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ThreadLabel
show (TimeoutId -> Int
unTimeoutId TimeoutId
nextTmid) forall a. [a] -> [a] -> [a]
++ ThreadLabel
">>")
                          Bool
True
      let !expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (TVar s Bool -> SimA s b
k TVar s Bool
tvar) ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { nextVid :: TVarId
nextVid = forall a. Enum a => a -> a
succ TVarId
nextVid }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> TVarId -> Time -> SimEventType
EventRegisterDelayCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) forall a b. (a -> b) -> a -> b
$
              forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> SimEventType
EventRegisterDelayFired TimeoutId
nextTmid) forall a b. (a -> b) -> a -> b
$
              SimTrace a
trace)

    RegisterDelay DiffTime
d TVar s Bool -> SimA s b
k ->
      {-# SCC "schedule.NewRegisterDelay.2" #-} do
      !TVar s Bool
tvar <- forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid
                          (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ThreadLabel
"<<timeout " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ThreadLabel
show (TimeoutId -> Int
unTimeoutId TimeoutId
nextTmid) forall a. [a] -> [a] -> [a]
++ ThreadLabel
">>")
                          Bool
False
      let !expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !timers' :: Timeouts s
timers' = forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert TimeoutId
nextTmid Time
expiry (forall s. TVar s Bool -> TimerCompletionInfo s
TimerRegisterDelay TVar s Bool
tvar) Timeouts s
timers
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (TVar s Bool -> SimA s b
k TVar s Bool
tvar) ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers   = Timeouts s
timers'
                                         , nextVid :: TVarId
nextVid  = forall a. Enum a => a -> a
succ TVarId
nextVid
                                         , nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl
                (TimeoutId -> TVarId -> Time -> SimEventType
EventRegisterDelayCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) SimTrace a
trace)

    ThreadDelay DiffTime
d SimA s b
k | DiffTime
d forall a. Ord a => a -> a -> Bool
< DiffTime
0 ->
      {-# SCC "schedule.NewThreadDelay" #-} do
      let !expiry :: Time
expiry    = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall a s. a -> SimA s a
Return ()) (forall s a a b.
TimeoutId -> SimA s a -> ControlStack s a a -> ControlStack s b a
DelayFrame TimeoutId
nextTmid SimA s b
k ControlStack s b a
ctl) }
          !simstate' :: SimState s a
simstate' = SimState s a
simstate { nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate'
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> Time -> SimEventType
EventThreadDelay TimeoutId
nextTmid Time
expiry) forall a b. (a -> b) -> a -> b
$
              forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> SimEventType
EventThreadDelayFired TimeoutId
nextTmid) forall a b. (a -> b) -> a -> b
$
              SimTrace a
trace)

    ThreadDelay DiffTime
d SimA s b
k ->
      {-# SCC "schedule.NewThreadDelay" #-} do
      let !expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !timers' :: Timeouts s
timers' = forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert TimeoutId
nextTmid Time
expiry (forall s. ThreadId -> TimeoutId -> TimerCompletionInfo s
TimerThreadDelay ThreadId
tid TimeoutId
nextTmid) Timeouts s
timers
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall a s. a -> SimA s a
Return ()) (forall s a a b.
TimeoutId -> SimA s a -> ControlStack s a a -> ControlStack s b a
DelayFrame TimeoutId
nextTmid SimA s b
k ControlStack s b a
ctl) }
      !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule (BlockedReason -> Deschedule
Blocked BlockedReason
BlockedOnOther) Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers   = Timeouts s
timers'
                                                                     , nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> Time -> SimEventType
EventThreadDelay TimeoutId
nextTmid Time
expiry) SimTrace a
trace)

    -- we treat negative timers as cancelled ones; for the record we put
    -- `EventTimerCreated` and `EventTimerCancelled` in the trace; This differs
    -- from `GHC.Event` behaviour.
    NewTimeout DiffTime
d Timeout s -> SimA s b
k | DiffTime
d forall a. Ord a => a -> a -> Bool
< DiffTime
0 ->
      {-# SCC "schedule.NewTimeout.1" #-} do
      let !t :: Timeout s
t       = forall s. TimeoutId -> Timeout s
NegativeTimeout TimeoutId
nextTmid
          !expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (Timeout s -> SimA s b
k Timeout s
t) ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> TVarId -> Time -> SimEventType
EventTimerCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) forall a b. (a -> b) -> a -> b
$
              forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> SimEventType
EventTimerCancelled TimeoutId
nextTmid) forall a b. (a -> b) -> a -> b
$
              SimTrace a
trace)

    NewTimeout DiffTime
d Timeout s -> SimA s b
k ->
      {-# SCC "schedule.NewTimeout.2" #-} do
      !TVar s TimeoutState
tvar  <- forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid
                           (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ThreadLabel
"<<timeout-state " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ThreadLabel
show (TimeoutId -> Int
unTimeoutId TimeoutId
nextTmid) forall a. [a] -> [a] -> [a]
++ ThreadLabel
">>")
                           TimeoutState
TimeoutPending
      let !expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          !t :: Timeout s
t       = forall s. TVar s TimeoutState -> TimeoutId -> Timeout s
Timeout TVar s TimeoutState
tvar TimeoutId
nextTmid
          !timers' :: Timeouts s
timers' = forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert TimeoutId
nextTmid Time
expiry (forall s. TVar s TimeoutState -> TimerCompletionInfo s
Timer TVar s TimeoutState
tvar) Timeouts s
timers
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (Timeout s -> SimA s b
k Timeout s
t) ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: Timeouts s
timers   = Timeouts s
timers'
                                         , nextVid :: TVarId
nextVid  = forall a. Enum a => a -> a
succ TVarId
nextVid
                                         , nextTmid :: TimeoutId
nextTmid = forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> TVarId -> Time -> SimEventType
EventTimerCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) SimTrace a
trace)

    CancelTimeout (Timeout TVar s TimeoutState
tvar TimeoutId
tmid) SimA s b
k ->
      {-# SCC "schedule.CancelTimeout" #-} do
      let !timers' :: Timeouts s
timers' = forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid Timeouts s
timers
          !thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      ![SomeTVar s]
written <- forall s. StmA s () -> ST s [SomeTVar s]
execAtomically' (forall s a. STM s a -> StmA s a
runSTM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar s TimeoutState
tvar TimeoutState
TimeoutCancelled)
      ([ThreadId]
wakeup, Map ThreadId (Set (Labelled TVarId))
wokeby) <- forall s.
[SomeTVar s]
-> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))
threadsUnblockedByWrites [SomeTVar s]
written
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
var) -> forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar s a
var) [SomeTVar s]
written
      let ([ThreadId]
unblocked,
           SimState s a
simstate') = forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
True [ThreadId]
wakeup SimState s a
simstate
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate' { timers :: Timeouts s
timers = Timeouts s
timers' }
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (TimeoutId -> SimEventType
EventTimerCancelled TimeoutId
tmid)
             forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany
                 [ (Time
time, ThreadId
tid', Maybe ThreadLabel
tlbl', [Labelled TVarId] -> SimEventType
EventTxWakeup [Labelled TVarId]
vids)
                 | ThreadId
tid' <- [ThreadId]
unblocked
                 , let tlbl' :: Maybe ThreadLabel
tlbl' = forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads
                 , let Just [Labelled TVarId]
vids = forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Set (Labelled TVarId))
wokeby ]
             forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

    -- cancelling a negative timer is a no-op
    CancelTimeout (NegativeTimeout TimeoutId
_tmid) SimA s b
k ->
      {-# SCC "schedule.CancelTimeout" #-} do
      -- negative timers are promptly removed from the state
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    Fork IOSim s ()
a ThreadId -> SimA s b
k ->
      {-# SCC "schedule.Fork" #-} do
      let !nextId :: Int
nextId   = forall s a. Thread s a -> Int
threadNextTId Thread s a
thread
          !tid' :: ThreadId
tid'     = ThreadId -> Int -> ThreadId
childThreadId ThreadId
tid Int
nextId
          !thread' :: Thread s a
thread'  = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (ThreadId -> SimA s b
k ThreadId
tid') ControlStack s b a
ctl
                             , threadNextTId :: Int
threadNextTId = forall a. Enum a => a -> a
succ Int
nextId }
          !thread'' :: Thread s a
thread'' = Thread { threadId :: ThreadId
threadId      = ThreadId
tid'
                             , threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s ()
a)
                                                             forall s a. ControlStack s () a
ForkFrame
                             , threadStatus :: ThreadStatus
threadStatus  = ThreadStatus
ThreadRunning
                             , threadMasking :: MaskingState
threadMasking = forall s a. Thread s a -> MaskingState
threadMasking Thread s a
thread
                             , threadThrowTo :: [(SomeException, Labelled ThreadId)]
threadThrowTo = []
                             , threadClockId :: ClockId
threadClockId = forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
                             , threadLabel :: Maybe ThreadLabel
threadLabel   = forall a. Maybe a
Nothing
                             , threadNextTId :: Int
threadNextTId = Int
1
                             }
          !threads' :: Map ThreadId (Thread s a)
threads' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
tid' Thread s a
thread'' Map ThreadId (Thread s a)
threads
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { runqueue :: Deque ThreadId
runqueue = forall a. a -> Deque a -> Deque a
Deque.snoc ThreadId
tid' Deque ThreadId
runqueue
                                         , threads :: Map ThreadId (Thread s a)
threads  = Map ThreadId (Thread s a)
threads' }
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (ThreadId -> SimEventType
EventThreadForked ThreadId
tid') SimTrace a
trace)

    Atomically STM s a
a a -> SimA s b
k ->
      {-# SCC "schedule.Atomically" #-} forall s a c.
Time
-> ThreadId
-> Maybe ThreadLabel
-> TVarId
-> StmA s a
-> (StmTxResult s a -> ST s (SimTrace c))
-> ST s (SimTrace c)
execAtomically Time
time ThreadId
tid Maybe ThreadLabel
tlbl TVarId
nextVid (forall s a. STM s a -> StmA s a
runSTM STM s a
a) forall a b. (a -> b) -> a -> b
$ \StmTxResult s a
res ->
      case StmTxResult s a
res of
        StmTxCommitted a
x [SomeTVar s]
written [SomeTVar s]
_read [SomeTVar s]
created
                         [Dynamic]
tvarDynamicTraces [ThreadLabel]
tvarStringTraces TVarId
nextVid' -> do
          (![ThreadId]
wakeup, Map ThreadId (Set (Labelled TVarId))
wokeby) <- forall s.
[SomeTVar s]
-> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))
threadsUnblockedByWrites [SomeTVar s]
written
          !()
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar s a
tvar) [SomeTVar s]
written
          let thread' :: Thread s a
thread'     = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
              ([ThreadId]
unblocked,
               SimState s a
simstate') = forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
True [ThreadId]
wakeup SimState s a
simstate
          [Labelled TVarId]
written' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s (Labelled TVarId)
labelledTVarId TVar s a
tvar) [SomeTVar s]
written
          [Labelled TVarId]
created' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s (Labelled TVarId)
labelledTVarId TVar s a
tvar) [SomeTVar s]
created
              -- We don't interrupt runnable threads to provide fairness
              -- anywhere else. We do it here by putting the tx that committed
              -- a transaction to the back of the runqueue, behind all other
              -- runnable threads, and behind the unblocked threads.
              -- For testing, we should have a more sophisticated policy to show
              -- that algorithms are not sensitive to the exact policy, so long
              -- as it is a fair policy (all runnable threads eventually run).
          !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Yield Thread s a
thread' SimState s a
simstate' { nextVid :: TVarId
nextVid  = TVarId
nextVid' }
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl ([Labelled TVarId]
-> [Labelled TVarId] -> Maybe Effect -> SimEventType
EventTxCommitted
                                             [Labelled TVarId]
written' [Labelled TVarId]
created' forall a. Maybe a
Nothing)
                 forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany
                     [ (Time
time, ThreadId
tid', Maybe ThreadLabel
tlbl', [Labelled TVarId] -> SimEventType
EventTxWakeup [Labelled TVarId]
vids')
                     | ThreadId
tid' <- [ThreadId]
unblocked
                     , let tlbl' :: Maybe ThreadLabel
tlbl' = forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads
                     , let Just [Labelled TVarId]
vids' = forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Set (Labelled TVarId))
wokeby ]
                 forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany
                     [ (Time
time, ThreadId
tid, Maybe ThreadLabel
tlbl, Dynamic -> SimEventType
EventLog Dynamic
tr)
                     | Dynamic
tr <- [Dynamic]
tvarDynamicTraces ]
                 forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany
                     [ (Time
time, ThreadId
tid, Maybe ThreadLabel
tlbl, ThreadLabel -> SimEventType
EventSay ThreadLabel
str)
                     | ThreadLabel
str <- [ThreadLabel]
tvarStringTraces ]
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl ([ThreadId] -> SimEventType
EventUnblocked [ThreadId]
unblocked)
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule Deschedule
Yield)
                 forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

        StmTxAborted [SomeTVar s]
_read SomeException
e -> do
          -- schedule this thread to immediately raise the exception
          let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl }
          !SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Maybe Effect -> SimEventType
EventTxAborted forall a. Maybe a
Nothing) SimTrace a
trace

        StmTxBlocked [SomeTVar s]
read -> do
          !()
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> forall s a. ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar ThreadId
tid TVar s a
tvar) [SomeTVar s]
read
          [Labelled TVarId]
vids <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s (Labelled TVarId)
labelledTVarId TVar s a
tvar) [SomeTVar s]
read
          !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule (BlockedReason -> Deschedule
Blocked BlockedReason
BlockedOnSTM) Thread s a
thread SimState s a
simstate
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl ([Labelled TVarId] -> Maybe Effect -> SimEventType
EventTxBlocked [Labelled TVarId]
vids forall a. Maybe a
Nothing)
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule (BlockedReason -> Deschedule
Blocked BlockedReason
BlockedOnSTM))
                 forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

    GetThreadId ThreadId -> SimA s b
k ->
      {-# SCC "schedule.GetThreadId" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (ThreadId -> SimA s b
k ThreadId
tid) ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    LabelThread ThreadId
tid' ThreadLabel
l SimA s b
k | ThreadId
tid' forall a. Eq a => a -> a -> Bool
== ThreadId
tid ->
      {-# SCC "schedule.LabelThread" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl
                           , threadLabel :: Maybe ThreadLabel
threadLabel   = forall a. a -> Maybe a
Just ThreadLabel
l }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    LabelThread ThreadId
tid' ThreadLabel
l SimA s b
k ->
      {-# SCC "schedule.LabelThread" #-} do
      let thread' :: Thread s a
thread'  = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
          threads' :: Map ThreadId (Thread s a)
threads' = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Thread s a
t -> Thread s a
t { threadLabel :: Maybe ThreadLabel
threadLabel = forall a. a -> Maybe a
Just ThreadLabel
l }) ThreadId
tid' Map ThreadId (Thread s a)
threads
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate { threads :: Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads' }

    GetMaskState MaskingState -> SimA s b
k ->
      {-# SCC "schedule.GetMaskState" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (MaskingState -> SimA s b
k MaskingState
maskst) ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate

    SetMaskState MaskingState
maskst' IOSim s a
action' a -> SimA s b
k ->
      {-# SCC "schedule.SetMaskState" #-} do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl
                                               (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action')
                                               (forall b s a a.
(b -> SimA s a)
-> MaskingState -> ControlStack s a a -> ControlStack s b a
MaskFrame a -> SimA s b
k MaskingState
maskst ControlStack s b a
ctl)
                           , threadMasking :: MaskingState
threadMasking = MaskingState
maskst' }
      SimTrace a
trace <-
        case MaskingState
maskst' of
          -- If we're now unmasked then check for any pending async exceptions
          MaskingState
Unmasked -> forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule Deschedule
Interruptable)
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Interruptable Thread s a
thread' SimState s a
simstate
          MaskingState
_        -> forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule                 Thread s a
thread' SimState s a
simstate
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (MaskingState -> SimEventType
EventMask MaskingState
maskst')
             forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

    ThrowTo SomeException
e ThreadId
tid' SimA s b
_ | ThreadId
tid' forall a. Eq a => a -> a -> Bool
== ThreadId
tid ->
      {-# SCC "schedule.ThrowTo" #-} do
      -- Throw to ourself is equivalent to a synchronous throw,
      -- and works irrespective of masking state since it does not block.
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl }
      SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> ThreadId -> SimEventType
EventThrowTo SomeException
e ThreadId
tid) SimTrace a
trace)

    ThrowTo SomeException
e ThreadId
tid' SimA s b
k ->
      {-# SCC "schedule.ThrowTo" #-} do
      let thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
          willBlock :: Bool
willBlock = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Thread s a)
threads of
                        Just Thread s a
t -> Bool -> Bool
not (forall s a. Thread s a -> Bool
threadInterruptible Thread s a
t)
                        Maybe (Thread s a)
_      -> Bool
False
      if Bool
willBlock
        then do
          -- The target thread has async exceptions masked so we add the
          -- exception and the source thread id to the pending async exceptions.
          let adjustTarget :: Thread s a -> Thread s a
adjustTarget Thread s a
t = Thread s a
t { threadThrowTo :: [(SomeException, Labelled ThreadId)]
threadThrowTo = (SomeException
e, forall a. a -> Maybe ThreadLabel -> Labelled a
Labelled ThreadId
tid Maybe ThreadLabel
tlbl) forall a. a -> [a] -> [a]
: forall s a. Thread s a -> [(SomeException, Labelled ThreadId)]
threadThrowTo Thread s a
t }
              threads' :: Map ThreadId (Thread s a)
threads'       = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Thread s a -> Thread s a
adjustTarget ThreadId
tid' Map ThreadId (Thread s a)
threads
          !SimTrace a
trace <- forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule (BlockedReason -> Deschedule
Blocked BlockedReason
BlockedOnOther) Thread s a
thread' SimState s a
simstate { threads :: Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads' }
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> ThreadId -> SimEventType
EventThrowTo SomeException
e ThreadId
tid')
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl SimEventType
EventThrowToBlocked
                 forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Deschedule -> SimEventType
EventDeschedule (BlockedReason -> Deschedule
Blocked BlockedReason
BlockedOnOther))
                 forall a b. (a -> b) -> a -> b
$ SimTrace a
trace
        else do
          -- The target thread has async exceptions unmasked, or is masked but
          -- is blocked (and all blocking operations are interruptible) then we
          -- raise the exception in that thread immediately. This will either
          -- cause it to terminate or enter an exception handler.
          -- In the meantime the thread masks new async exceptions. This will
          -- be resolved if the thread terminates or if it leaves the exception
          -- handler (when restoring the masking state would trigger the any
          -- new pending async exception).
          let adjustTarget :: Thread s a -> Thread s a
adjustTarget t :: Thread s a
t@Thread{ threadControl :: forall s a. Thread s a -> ThreadControl s a
threadControl = ThreadControl SimA s b
_ ControlStack s b a
ctl' } =
                Thread s a
t { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl'
                  , threadStatus :: ThreadStatus
threadStatus  = ThreadStatus
ThreadRunning
                  }
              simstate' :: SimState s a
simstate'@SimState { threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads' }
                         = forall a b. (a, b) -> b
snd (forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
False [ThreadId
tid'] SimState s a
simstate)
              threads'' :: Map ThreadId (Thread s a)
threads''  = forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Thread s a -> Thread s a
adjustTarget ThreadId
tid' Map ThreadId (Thread s a)
threads'
              simstate'' :: SimState s a
simstate'' = SimState s a
simstate' { threads :: Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads'' }

          SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate''
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (SomeException -> ThreadId -> SimEventType
EventThrowTo SomeException
e ThreadId
tid')
                 forall a b. (a -> b) -> a -> b
$ SimTrace a
trace

    YieldSim SimA s b
k -> do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Yield Thread s a
thread' SimState s a
simstate

    -- ExploreRaces is ignored by this simulator
    ExploreRaces SimA s b
k ->
      {-# SCC "schedule.ExploreRaces" #-}
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread{ threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl } SimState s a
simstate

    Fix x -> IOSim s x
f x -> SimA s b
k ->
      {-# SCC "schedule.Fix" #-} do
      STRef s x
r <- forall a s. a -> ST s (STRef s a)
newSTRef (forall a e. Exception e => e -> a
throw NonTermination
NonTermination)
      x
x <- forall s a. ST s a -> ST s a
unsafeInterleaveST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s x
r
      let k' :: SimA s b
k' = forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim (x -> IOSim s x
f x
x) forall a b. (a -> b) -> a -> b
$ \x
x' ->
                  forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST (forall s a. ST s a -> ST s a
lazyToStrictST (forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s x
r x
x')) (\() -> x -> SimA s b
k x
x')
          thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k' ControlStack s b a
ctl }
      forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate


threadInterruptible :: Thread s a -> Bool
threadInterruptible :: forall s a. Thread s a -> Bool
threadInterruptible Thread s a
thread =
    case forall s a. Thread s a -> MaskingState
threadMasking Thread s a
thread of
      MaskingState
Unmasked                   -> Bool
True
      MaskingState
MaskedInterruptible
        | forall s a. Thread s a -> Bool
isThreadBlocked Thread s a
thread -> Bool
True  -- blocking operations are interruptible
        | Bool
otherwise              -> Bool
False
      MaskingState
MaskedUninterruptible      -> Bool
False

deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule :: forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Yield !Thread s a
thread !simstate :: SimState s a
simstate@SimState{Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads} =

    -- We don't interrupt runnable threads to provide fairness anywhere else.
    -- We do it here by putting the thread to the back of the runqueue, behind
    -- all other runnable threads.
    --
    -- For testing, we should have a more sophisticated policy to show that
    -- algorithms are not sensitive to the exact policy, so long as it is a
    -- fair policy (all runnable threads eventually run).

    {-# SCC "deschedule.Yield" #-}
    let runqueue' :: Deque ThreadId
runqueue' = forall a. a -> Deque a -> Deque a
Deque.snoc (forall s a. Thread s a -> ThreadId
threadId Thread s a
thread) Deque ThreadId
runqueue
        threads' :: Map ThreadId (Thread s a)
threads'  = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. Thread s a -> ThreadId
threadId Thread s a
thread) Thread s a
thread Map ThreadId (Thread s a)
threads in
    forall s a. SimState s a -> ST s (SimTrace a)
reschedule SimState s a
simstate { runqueue :: Deque ThreadId
runqueue = Deque ThreadId
runqueue', threads :: Map ThreadId (Thread s a)
threads  = Map ThreadId (Thread s a)
threads' }

deschedule Deschedule
Interruptable !thread :: Thread s a
thread@Thread {
                           threadId :: forall s a. Thread s a -> ThreadId
threadId      = ThreadId
tid,
                           threadControl :: forall s a. Thread s a -> ThreadControl s a
threadControl = ThreadControl SimA s b
_ ControlStack s b a
ctl,
                           threadMasking :: forall s a. Thread s a -> MaskingState
threadMasking = MaskingState
Unmasked,
                           threadThrowTo :: forall s a. Thread s a -> [(SomeException, Labelled ThreadId)]
threadThrowTo = (SomeException
e, Labelled ThreadId
tid') : [(SomeException, Labelled ThreadId)]
etids,
                           threadLabel :: forall s a. Thread s a -> Maybe ThreadLabel
threadLabel   = Maybe ThreadLabel
tlbl
                         }
                         !simstate :: SimState s a
simstate@SimState{ curTime :: forall s a. SimState s a -> Time
curTime = Time
time, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads } =

    -- We're unmasking, but there are pending blocked async exceptions.
    -- So immediately raise the exception and unblock the blocked thread
    -- if possible.
    {-# SCC "deschedule.Interruptable.Unmasked" #-}
    let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl
                         , threadMasking :: MaskingState
threadMasking = MaskingState
MaskedInterruptible
                         , threadThrowTo :: [(SomeException, Labelled ThreadId)]
threadThrowTo = [(SomeException, Labelled ThreadId)]
etids }
        ([ThreadId]
unblocked,
         SimState s a
simstate') = forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
False [forall a. Labelled a -> a
l_labelled Labelled ThreadId
tid'] SimState s a
simstate
    in do
    SimTrace a
trace <- forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread' SimState s a
simstate'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Labelled ThreadId -> SimEventType
EventThrowToUnmasked Labelled ThreadId
tid')
           forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany [ (Time
time, ThreadId
tid'', Maybe ThreadLabel
tlbl'', SimEventType
EventThrowToWakeup)
                       | ThreadId
tid'' <- [ThreadId]
unblocked
                       , let tlbl'' :: Maybe ThreadLabel
tlbl'' = forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid'' Map ThreadId (Thread s a)
threads ]
             SimTrace a
trace

deschedule Deschedule
Interruptable !Thread s a
thread !SimState s a
simstate =
    -- Either masked or unmasked but no pending async exceptions.
    -- Either way, just carry on.
    {-# SCC "deschedule.Interruptable.Masked" #-}
    forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread SimState s a
simstate

deschedule (Blocked BlockedReason
_blockedReason) !thread :: Thread s a
thread@Thread { threadThrowTo :: forall s a. Thread s a -> [(SomeException, Labelled ThreadId)]
threadThrowTo = (SomeException, Labelled ThreadId)
_ : [(SomeException, Labelled ThreadId)]
_
                                                   , threadMasking :: forall s a. Thread s a -> MaskingState
threadMasking = MaskingState
maskst } !SimState s a
simstate
    | MaskingState
maskst forall a. Eq a => a -> a -> Bool
/= MaskingState
MaskedUninterruptible =
    -- We're doing a blocking operation, which is an interrupt point even if
    -- we have async exceptions masked, and there are pending blocked async
    -- exceptions. So immediately raise the exception and unblock the blocked
    -- thread if possible.
    {-# SCC "deschedule.Interruptable.Blocked.1" #-}
    forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (SimTrace a)
deschedule Deschedule
Interruptable Thread s a
thread { threadMasking :: MaskingState
threadMasking = MaskingState
Unmasked } SimState s a
simstate

deschedule (Blocked BlockedReason
blockedReason) !Thread s a
thread !simstate :: SimState s a
simstate@SimState{Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads} =
    {-# SCC "deschedule.Interruptable.Blocked.2" #-}
    let thread' :: Thread s a
thread'  = Thread s a
thread { threadStatus :: ThreadStatus
threadStatus = BlockedReason -> ThreadStatus
ThreadBlocked BlockedReason
blockedReason }
        threads' :: Map ThreadId (Thread s a)
threads' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. Thread s a -> ThreadId
threadId Thread s a
thread') Thread s a
thread' Map ThreadId (Thread s a)
threads in
    forall s a. SimState s a -> ST s (SimTrace a)
reschedule SimState s a
simstate { threads :: Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads' }

deschedule Deschedule
Terminated !Thread s a
thread !simstate :: SimState s a
simstate@SimState{ curTime :: forall s a. SimState s a -> Time
curTime = Time
time, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads } =
    -- This thread is done. If there are other threads blocked in a
    -- ThrowTo targeted at this thread then we can wake them up now.
    {-# SCC "deschedule.Terminated" #-}
    let !wakeup :: [ThreadId]
wakeup      = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Labelled a -> a
l_labelled forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall a. [a] -> [a]
reverse (forall s a. Thread s a -> [(SomeException, Labelled ThreadId)]
threadThrowTo Thread s a
thread))
        ([ThreadId]
unblocked,
         !SimState s a
simstate') = forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
False [ThreadId]
wakeup SimState s a
simstate
    in do
    !SimTrace a
trace <- forall s a. SimState s a -> ST s (SimTrace a)
reschedule SimState s a
simstate'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany
               [ (Time
time, ThreadId
tid', Maybe ThreadLabel
tlbl', SimEventType
EventThrowToWakeup)
               | ThreadId
tid' <- [ThreadId]
unblocked
               , let tlbl' :: Maybe ThreadLabel
tlbl' = forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads ]
               SimTrace a
trace

deschedule Deschedule
Sleep Thread s a
_thread SimState s a
_simstate =
    forall a. (?callStack::CallStack) => ThreadLabel -> a
error ThreadLabel
"IOSim: impossible happend"

-- When there is no current running thread but the runqueue is non-empty then
-- schedule the next one to run.
reschedule :: SimState s a -> ST s (SimTrace a)
reschedule :: forall s a. SimState s a -> ST s (SimTrace a)
reschedule !simstate :: SimState s a
simstate@SimState{ Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads }
  | Just (!ThreadId
tid, Deque ThreadId
runqueue') <- forall a. Deque a -> Maybe (a, Deque a)
Deque.uncons Deque ThreadId
runqueue =
    {-# SCC "reschedule.Just" #-}
    let thread :: Thread s a
thread = Map ThreadId (Thread s a)
threads forall k a. Ord k => Map k a -> k -> a
Map.! ThreadId
tid in
    forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
thread SimState s a
simstate { runqueue :: Deque ThreadId
runqueue = Deque ThreadId
runqueue'
                             , threads :: Map ThreadId (Thread s a)
threads  = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ThreadId
tid Map ThreadId (Thread s a)
threads }

-- But when there are no runnable threads, we advance the time to the next
-- timer event, or stop.
reschedule !simstate :: SimState s a
simstate@SimState{ Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads, Timeouts s
timers :: Timeouts s
timers :: forall s a. SimState s a -> Timeouts s
timers, curTime :: forall s a. SimState s a -> Time
curTime = Time
time } =
    {-# SCC "reschedule.Nothing" #-}

    -- important to get all events that expire at this time
    case forall k p a.
(Ord k, Ord p) =>
OrdPSQ k p a -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums Timeouts s
timers of
      Maybe ([TimeoutId], Time, [TimerCompletionInfo s], Timeouts s)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Time -> [Labelled ThreadId] -> SimTrace a
TraceDeadlock Time
time (forall s a. Map ThreadId (Thread s a) -> [Labelled ThreadId]
labelledThreads Map ThreadId (Thread s a)
threads))

      Just ([TimeoutId]
tmids, !Time
time', ![TimerCompletionInfo s]
fired, !Timeouts s
timers') -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Time
time' forall a. Ord a => a -> a -> Bool
>= Time
time) forall a b. (a -> b) -> a -> b
$ do
        -- Reuse the STM functionality here to write all the timer TVars.
        -- Simplify to a special case that only reads and writes TVars.
        ![SomeTVar s]
written <- forall s. StmA s () -> ST s [SomeTVar s]
execAtomically' (forall s a. STM s a -> StmA s a
runSTM forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {m :: * -> *} {s}.
(TVar m ~ TVar s, MonadSTM m) =>
TimerCompletionInfo s -> STM m ()
timeoutSTMAction [TimerCompletionInfo s]
fired)
        ([ThreadId]
wakeupSTM, Map ThreadId (Set (Labelled TVarId))
wokeby) <- forall s.
[SomeTVar s]
-> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))
threadsUnblockedByWrites [SomeTVar s]
written
        !()
_ <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar s a
tvar) [SomeTVar s]
written

            -- Check all fired threadDelays
        let wakeupThreadDelay :: [(ThreadId, TimeoutId)]
wakeupThreadDelay = [ (ThreadId
tid, TimeoutId
tmid) | TimerThreadDelay ThreadId
tid TimeoutId
tmid <- [TimerCompletionInfo s]
fired ]
            wakeup :: [ThreadId]
wakeup            = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [(ThreadId, TimeoutId)]
wakeupThreadDelay forall a. [a] -> [a] -> [a]
++ [ThreadId]
wakeupSTM
            ([ThreadId]
_, !SimState s a
simstate')   = forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads Bool
False [ThreadId]
wakeup SimState s a
simstate

            -- For each 'timeout' action where the timeout has fired, start a
            -- new thread to execute throwTo to interrupt the action.
            !timeoutExpired :: [(ThreadId, TimeoutId, TMVarDefault (IOSim s) ThreadId)]
timeoutExpired = [ (ThreadId
tid, TimeoutId
tmid, TMVar (IOSim s) ThreadId
lock)
                              | TimerTimeout ThreadId
tid TimeoutId
tmid TMVar (IOSim s) ThreadId
lock <- [TimerCompletionInfo s]
fired ]

        !SimState s a
simstate'' <- forall s a.
[(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]
-> SimState s a -> ST s (SimState s a)
forkTimeoutInterruptThreads [(ThreadId, TimeoutId, TMVarDefault (IOSim s) ThreadId)]
timeoutExpired SimState s a
simstate'

        !SimTrace a
trace <- forall s a. SimState s a -> ST s (SimTrace a)
reschedule SimState s a
simstate'' { curTime :: Time
curTime = Time
time'
                                        , timers :: Timeouts s
timers  = Timeouts s
timers' }

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
          forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany ([ ( Time
time', [Int] -> ThreadId
ThreadId [-Int
1], forall a. a -> Maybe a
Just ThreadLabel
"timer"
                       , TimeoutId -> SimEventType
EventTimerFired TimeoutId
tmid)
                     | (TimeoutId
tmid, Timer TVar s TimeoutState
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TimeoutId]
tmids [TimerCompletionInfo s]
fired ]
                  forall a. [a] -> [a] -> [a]
++ [ ( Time
time', [Int] -> ThreadId
ThreadId [-Int
1], forall a. a -> Maybe a
Just ThreadLabel
"register delay timer"
                       , TimeoutId -> SimEventType
EventRegisterDelayFired TimeoutId
tmid)
                     | (TimeoutId
tmid, TimerRegisterDelay TVar s Bool
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [TimeoutId]
tmids [TimerCompletionInfo s]
fired ]
                  forall a. [a] -> [a] -> [a]
++ [ (Time
time', ThreadId
tid', Maybe ThreadLabel
tlbl', [Labelled TVarId] -> SimEventType
EventTxWakeup [Labelled TVarId]
vids)
                     | ThreadId
tid' <- [ThreadId]
wakeupSTM
                     , let tlbl' :: Maybe ThreadLabel
tlbl' = forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads
                     , let Just [Labelled TVarId]
vids = forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Set (Labelled TVarId))
wokeby ]
                  forall a. [a] -> [a] -> [a]
++ [ ( Time
time', ThreadId
tid, forall a. a -> Maybe a
Just ThreadLabel
"thread delay timer"
                       , TimeoutId -> SimEventType
EventThreadDelayFired TimeoutId
tmid)
                     | (ThreadId
tid, TimeoutId
tmid) <- [(ThreadId, TimeoutId)]
wakeupThreadDelay ]
                  forall a. [a] -> [a] -> [a]
++ [ ( Time
time', ThreadId
tid, forall a. a -> Maybe a
Just ThreadLabel
"timeout timer"
                       , TimeoutId -> SimEventType
EventTimeoutFired TimeoutId
tmid)
                     | (ThreadId
tid, TimeoutId
tmid, TMVarDefault (IOSim s) ThreadId
_) <- [(ThreadId, TimeoutId, TMVarDefault (IOSim s) ThreadId)]
timeoutExpired ]
                  forall a. [a] -> [a] -> [a]
++ [ ( Time
time', ThreadId
tid, forall a. a -> Maybe a
Just ThreadLabel
"thread forked"
                       , ThreadId -> SimEventType
EventThreadForked ThreadId
tid)
                     | (ThreadId
tid, TimeoutId
_, TMVarDefault (IOSim s) ThreadId
_) <- [(ThreadId, TimeoutId, TMVarDefault (IOSim s) ThreadId)]
timeoutExpired ])
                    SimTrace a
trace
  where
    timeoutSTMAction :: TimerCompletionInfo s -> STM m ()
timeoutSTMAction (Timer TVar s TimeoutState
var) = do
      TimeoutState
x <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar s TimeoutState
var
      case TimeoutState
x of
        TimeoutState
TimeoutPending   -> forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar s TimeoutState
var TimeoutState
TimeoutFired
        TimeoutState
TimeoutFired     -> forall a. (?callStack::CallStack) => ThreadLabel -> a
error ThreadLabel
"MonadTimer(Sim): invariant violation"
        TimeoutState
TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    timeoutSTMAction (TimerRegisterDelay TVar s Bool
var) = forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar s Bool
var Bool
True
    -- Note that 'threadDelay' is not handled via STM style wakeup, but rather
    -- it's handled directly above with 'wakeupThreadDelay' and 'unblockThreads'
    timeoutSTMAction TimerThreadDelay{}       = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    timeoutSTMAction TimerTimeout{}           = forall (m :: * -> *) a. Monad m => a -> m a
return ()

unblockThreads :: Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads :: forall s a.
Bool -> [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads !Bool
onlySTM ![ThreadId]
wakeup !simstate :: SimState s a
simstate@SimState {Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads} =
    -- To preserve our invariants (that threadBlocked is correct)
    -- we update the runqueue and threads together here
    ([ThreadId]
unblocked, SimState s a
simstate {
                  runqueue :: Deque ThreadId
runqueue = Deque ThreadId
runqueue forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> Deque a
Deque.fromList [ThreadId]
unblocked,
                  threads :: Map ThreadId (Thread s a)
threads  = Map ThreadId (Thread s a)
threads'
                })
  where
    -- can only unblock if the thread exists and is blocked (not running)
    !unblocked :: [ThreadId]
unblocked = [ ThreadId
tid
                 | ThreadId
tid <- [ThreadId]
wakeup
                 , case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid Map ThreadId (Thread s a)
threads of
                    Just Thread { threadStatus :: forall s a. Thread s a -> ThreadStatus
threadStatus = ThreadBlocked BlockedReason
BlockedOnOther }
                      -> Bool -> Bool
not Bool
onlySTM
                    Just Thread { threadStatus :: forall s a. Thread s a -> ThreadStatus
threadStatus = ThreadBlocked BlockedReason
BlockedOnSTM }
                      -> Bool
True
                    Maybe (Thread s a)
_ -> Bool
False
                 ]
    -- and in which case we mark them as now running
    !threads' :: Map ThreadId (Thread s a)
threads'  = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
                   (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Thread s a
t -> Thread s a
t { threadStatus :: ThreadStatus
threadStatus = ThreadStatus
ThreadRunning })))
                   Map ThreadId (Thread s a)
threads
                   [ThreadId]
unblocked

-- | This function receives a list of TimerTimeout values that represent threads
-- for which the timeout expired and kills the running thread if needed.
--
-- This function is responsible for the second part of the race condition issue
-- and relates to the 'schedule's 'TimeoutFrame' locking explanation (here is
-- where the assassin threads are launched. So, as explained previously, at this
-- point in code, the timeout expired so we need to interrupt the running
-- thread. If the running thread finished at the same time the timeout expired
-- we have a race condition. To deal with this race condition what we do is
-- look at the lock value. If it is 'Locked' this means that the running thread
-- already finished (or won the race) so we can safely do nothing. Otherwise, if
-- the lock value is 'NotLocked' we need to acquire the lock and launch an
-- assassin thread that is going to interrupt the running one. Note that we
-- should run this interrupting thread in an unmasked state since it might
-- receive a 'ThreadKilled' exception.
--
forkTimeoutInterruptThreads :: forall s a.
                               [(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]
                            -> SimState s a
                            -> ST s (SimState s a)
forkTimeoutInterruptThreads :: forall s a.
[(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]
-> SimState s a -> ST s (SimState s a)
forkTimeoutInterruptThreads [(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]
timeoutExpired SimState s a
simState =
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\st :: SimState s a
st@SimState{ Deque ThreadId
runqueue :: Deque ThreadId
runqueue :: forall s a. SimState s a -> Deque ThreadId
runqueue, Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads }
           (Thread s a
t, TMVar TVar (IOSim s) (Maybe ThreadId)
lock)
          -> do
            Maybe ThreadId
v <- forall s a. TVar s a -> ST s a
execReadTVar TVar (IOSim s) (Maybe ThreadId)
lock
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe ThreadId
v of
              Maybe ThreadId
Nothing -> SimState s a
st { runqueue :: Deque ThreadId
runqueue = forall a. a -> Deque a -> Deque a
Deque.snoc (forall s a. Thread s a -> ThreadId
threadId Thread s a
t) Deque ThreadId
runqueue,
                              threads :: Map ThreadId (Thread s a)
threads  = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. Thread s a -> ThreadId
threadId Thread s a
t) Thread s a
t Map ThreadId (Thread s a)
threads
                            }
              Just ThreadId
_  -> SimState s a
st
          )
          SimState s a
simState'
          [(Thread s a, TMVar (IOSim s) ThreadId)]
throwToThread

  where
    -- we launch a thread responsible for throwing an AsyncCancelled exception
    -- to the thread which timeout expired
    throwToThread :: [(Thread s a, TMVar (IOSim s) ThreadId)] 

    (SimState s a
simState', [(Thread s a, TMVar (IOSim s) ThreadId)]
[(Thread s a, TMVarDefault (IOSim s) ThreadId)]
throwToThread) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumR SimState s a
-> (ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)
-> (SimState s a, (Thread s a, TMVar (IOSim s) ThreadId))
fn SimState s a
simState [(ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)]
timeoutExpired 
      where
        fn :: SimState s a
           -> (ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)
           -> (SimState s a, (Thread s a, TMVar (IOSim s) ThreadId))
        fn :: SimState s a
-> (ThreadId, TimeoutId, TMVar (IOSim s) ThreadId)
-> (SimState s a, (Thread s a, TMVar (IOSim s) ThreadId))
fn state :: SimState s a
state@SimState { Map ThreadId (Thread s a)
threads :: Map ThreadId (Thread s a)
threads :: forall s a. SimState s a -> Map ThreadId (Thread s a)
threads } (ThreadId
tid, TimeoutId
tmid, TMVar (IOSim s) ThreadId
lock) =
          let t :: Thread s a
t = case ThreadId
tid forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map ThreadId (Thread s a)
threads of
                    Just Thread s a
t' -> Thread s a
t'
                    Maybe (Thread s a)
Nothing -> forall a. (?callStack::CallStack) => ThreadLabel -> a
error (ThreadLabel
"IOSim: internal error: unknown thread " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> ThreadLabel
show ThreadId
tid)
              nextId :: Int
nextId   = forall s a. Thread s a -> Int
threadNextTId Thread s a
t
          in ( SimState s a
state { threads :: Map ThreadId (Thread s a)
threads = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
tid Thread s a
t { threadNextTId :: Int
threadNextTId = forall a. Enum a => a -> a
succ Int
nextId } Map ThreadId (Thread s a)
threads }
             , ( Thread { threadId :: ThreadId
threadId      = ThreadId -> Int -> ThreadId
childThreadId ThreadId
tid Int
nextId,
                            threadControl :: ThreadControl s a
threadControl =
                              forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl
                               (forall s a. IOSim s a -> SimA s a
runIOSim forall a b. (a -> b) -> a -> b
$ do
                                  ThreadId
mtid <- forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
                                  Bool
v2 <- forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m Bool
tryPutTMVar TMVar (IOSim s) ThreadId
lock ThreadId
mtid
                                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v2 forall a b. (a -> b) -> a -> b
$
                                    forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId
tid (forall e. Exception e => e -> SomeException
toException (TimeoutId -> TimeoutException
TimeoutException TimeoutId
tmid)))
                               forall s a. ControlStack s () a
ForkFrame,
                            threadStatus :: ThreadStatus
threadStatus  = ThreadStatus
ThreadRunning,
                            threadMasking :: MaskingState
threadMasking = MaskingState
Unmasked,
                            threadThrowTo :: [(SomeException, Labelled ThreadId)]
threadThrowTo = [],
                            threadClockId :: ClockId
threadClockId = forall s a. Thread s a -> ClockId
threadClockId Thread s a
t,
                            threadLabel :: Maybe ThreadLabel
threadLabel   = forall a. a -> Maybe a
Just ThreadLabel
"timeout-forked-thread",
                            threadNextTId :: Int
threadNextTId = Int
1
                          }
                , TMVar (IOSim s) ThreadId
lock
                )
             )

-- | Iterate through the control stack to find an enclosing exception handler
-- of the right type, or unwind all the way to the top level for the thread.
--
-- Also return if it's the main thread or a forked thread since we handle the
-- cases differently.
--
-- Also remove timeouts associated to frames we unwind.
--
unwindControlStack :: forall s a.
                      SomeException
                   -> Thread s a
                   -> Timeouts s
                   -> ( Either Bool (Thread s a)
                      , Timeouts s
                      )
unwindControlStack :: forall s a.
SomeException
-> Thread s a
-> Timeouts s
-> (Either Bool (Thread s a), Timeouts s)
unwindControlStack SomeException
e Thread s a
thread = \Timeouts s
timers ->
    case forall s a. Thread s a -> ThreadControl s a
threadControl Thread s a
thread of
      ThreadControl SimA s b
_ ControlStack s b a
ctl ->
        forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind (forall s a. Thread s a -> MaskingState
threadMasking Thread s a
thread) ControlStack s b a
ctl Timeouts s
timers
  where
    unwind :: forall s' c. MaskingState
           -> ControlStack s' c a
           -> OrdPSQ TimeoutId Time (TimerCompletionInfo s)
           -> (Either Bool (Thread s' a), OrdPSQ TimeoutId Time (TimerCompletionInfo s))
    unwind :: forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind MaskingState
_  ControlStack s' c a
MainFrame                 Timeouts s
timers = (forall a b. a -> Either a b
Left Bool
True, Timeouts s
timers)
    unwind MaskingState
_  ControlStack s' c a
ForkFrame                 Timeouts s
timers = (forall a b. a -> Either a b
Left Bool
False, Timeouts s
timers)
    unwind MaskingState
_ (MaskFrame c -> SimA s' c
_k MaskingState
maskst' ControlStack s' c a
ctl) Timeouts s
timers = forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind MaskingState
maskst' ControlStack s' c a
ctl Timeouts s
timers

    unwind MaskingState
maskst (CatchFrame e -> SimA s' c
handler c -> SimA s' c
k ControlStack s' c a
ctl) Timeouts s
timers =
      case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        -- not the right type, unwind to the next containing handler
        Maybe e
Nothing -> forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind MaskingState
maskst ControlStack s' c a
ctl Timeouts s
timers

        -- Ok! We will be able to continue the thread with the handler
        -- followed by the continuation after the catch
        Just e
e' -> ( forall a b. b -> Either a b
Right Thread s a
thread {
                              -- As per async exception rules, the handler is run
                              -- masked
                             threadControl :: ThreadControl s' a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (e -> SimA s' c
handler e
e')
                                                           (forall b s a a.
(b -> SimA s a)
-> MaskingState -> ControlStack s a a -> ControlStack s b a
MaskFrame c -> SimA s' c
k MaskingState
maskst ControlStack s' c a
ctl),
                             threadMasking :: MaskingState
threadMasking = MaskingState -> MaskingState
atLeastInterruptibleMask MaskingState
maskst
                           }
                   , Timeouts s
timers
                   )

    -- Either Timeout fired or the action threw an exception.
    -- - If Timeout fired, then it was possibly during this thread's execution
    --   so we need to run the continuation with a Nothing value.
    -- - If the timeout action threw an exception we need to keep unwinding the
    --   control stack looking for a handler to this exception.
    unwind MaskingState
maskst (TimeoutFrame TimeoutId
tmid TMVar (IOSim s') ThreadId
_ Maybe c -> SimA s' c
k ControlStack s' c a
ctl) Timeouts s
timers =
        case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
          -- Exception came from timeout expiring
          Just (TimeoutException TimeoutId
tmid') | TimeoutId
tmid forall a. Eq a => a -> a -> Bool
== TimeoutId
tmid' ->
            (forall a b. b -> Either a b
Right Thread s a
thread { threadControl :: ThreadControl s' a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (Maybe c -> SimA s' c
k forall a. Maybe a
Nothing) ControlStack s' c a
ctl }, Timeouts s
timers')
          -- Exception came from a different exception
          Maybe TimeoutException
_ -> forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind MaskingState
maskst ControlStack s' c a
ctl Timeouts s
timers'
      where
        -- Remove the timeout associated with the 'TimeoutFrame'.
        timers' :: Timeouts s
timers' = forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid Timeouts s
timers

    unwind MaskingState
maskst (DelayFrame TimeoutId
tmid SimA s' c
_k ControlStack s' c a
ctl) Timeouts s
timers =
        forall s' c.
MaskingState
-> ControlStack s' c a
-> Timeouts s
-> (Either Bool (Thread s' a), Timeouts s)
unwind MaskingState
maskst ControlStack s' c a
ctl Timeouts s
timers'
      where
        -- Remove the timeout associated with the 'DelayFrame'.
        timers' :: Timeouts s
timers' = forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid Timeouts s
timers


    atLeastInterruptibleMask :: MaskingState -> MaskingState
    atLeastInterruptibleMask :: MaskingState -> MaskingState
atLeastInterruptibleMask MaskingState
Unmasked = MaskingState
MaskedInterruptible
    atLeastInterruptibleMask MaskingState
ms       = MaskingState
ms


removeMinimums :: (Ord k, Ord p)
               => OrdPSQ k p a
               -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums :: forall k p a.
(Ord k, Ord p) =>
OrdPSQ k p a -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums = \OrdPSQ k p a
psq ->
    case forall k p v.
(Ord k, Ord p) =>
OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v)
PSQ.minView OrdPSQ k p a
psq of
      Maybe (k, p, a, OrdPSQ k p a)
Nothing              -> forall a. Maybe a
Nothing
      Just (k
k, p
p, a
x, OrdPSQ k p a
psq') -> forall a. a -> Maybe a
Just (forall {a} {b} {a}.
(Ord a, Ord b) =>
[a] -> b -> [a] -> OrdPSQ a b a -> ([a], b, [a], OrdPSQ a b a)
collectAll [k
k] p
p [a
x] OrdPSQ k p a
psq')
  where
    collectAll :: [a] -> b -> [a] -> OrdPSQ a b a -> ([a], b, [a], OrdPSQ a b a)
collectAll ![a]
ks !b
p ![a]
xs !OrdPSQ a b a
psq =
      case forall k p v.
(Ord k, Ord p) =>
OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v)
PSQ.minView OrdPSQ a b a
psq of
        Just (a
k, b
p', a
x, OrdPSQ a b a
psq')
          | b
p forall a. Eq a => a -> a -> Bool
== b
p' -> [a] -> b -> [a] -> OrdPSQ a b a -> ([a], b, [a], OrdPSQ a b a)
collectAll (a
kforall a. a -> [a] -> [a]
:[a]
ks) b
p (a
xforall a. a -> [a] -> [a]
:[a]
xs) OrdPSQ a b a
psq'
        Maybe (a, b, a, OrdPSQ a b a)
_           -> (forall a. [a] -> [a]
reverse [a]
ks, b
p, forall a. [a] -> [a]
reverse [a]
xs, OrdPSQ a b a
psq)

traceMany :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
          -> SimTrace a -> SimTrace a
traceMany :: forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany []                      SimTrace a
trace = SimTrace a
trace
traceMany ((Time
time, ThreadId
tid, Maybe ThreadLabel
tlbl, SimEventType
event):[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
ts) SimTrace a
trace =
    forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl SimEventType
event (forall a.
[(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
-> SimTrace a -> SimTrace a
traceMany [(Time, ThreadId, Maybe ThreadLabel, SimEventType)]
ts SimTrace a
trace)

lookupThreadLabel :: ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel :: forall s a.
ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel ThreadId
tid Map ThreadId (Thread s a)
threads = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall s a. Thread s a -> Maybe ThreadLabel
threadLabel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid Map ThreadId (Thread s a)
threads)


-- | The most general method of running 'IOSim' is in 'ST' monad.  One can
-- recover failures or the result from 'SimTrace' with
-- 'Control.Monad.IOSim.traceResult', or access 'SimEventType's generated by the
-- computation with 'Control.Monad.IOSim.traceEvents'.  A slightly more
-- convenient way is exposed by 'Control.Monad.IOSim.runSimTrace'.
--
runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)
runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a)
runSimTraceST IOSim s a
mainAction = forall s a. Thread s a -> SimState s a -> ST s (SimTrace a)
schedule Thread s a
mainThread forall s a. SimState s a
initialState
  where
    mainThread :: Thread s a
mainThread =
      Thread {
        threadId :: ThreadId
threadId      = [Int] -> ThreadId
ThreadId [],
        threadControl :: ThreadControl s a
threadControl = forall s a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
mainAction) forall s a. ControlStack s a a
MainFrame,
        threadStatus :: ThreadStatus
threadStatus  = ThreadStatus
ThreadRunning,
        threadMasking :: MaskingState
threadMasking = MaskingState
Unmasked,
        threadThrowTo :: [(SomeException, Labelled ThreadId)]
threadThrowTo = [],
        threadClockId :: ClockId
threadClockId = [Int] -> ClockId
ClockId [],
        threadLabel :: Maybe ThreadLabel
threadLabel   = forall a. a -> Maybe a
Just ThreadLabel
"main",
        threadNextTId :: Int
threadNextTId = Int
1
      }


--
-- Executing STM Transactions
--

execAtomically :: forall s a c.
                  Time
               -> ThreadId
               -> Maybe ThreadLabel
               -> TVarId
               -> StmA s a
               -> (StmTxResult s a -> ST s (SimTrace c))
               -> ST s (SimTrace c)
execAtomically :: forall s a c.
Time
-> ThreadId
-> Maybe ThreadLabel
-> TVarId
-> StmA s a
-> (StmTxResult s a -> ST s (SimTrace c))
-> ST s (SimTrace c)
execAtomically !Time
time !ThreadId
tid !Maybe ThreadLabel
tlbl !TVarId
nextVid0 StmA s a
action0 StmTxResult s a -> ST s (SimTrace c)
k0 =
    forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go forall s a. StmStack s a a
AtomicallyFrame forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty [] [] TVarId
nextVid0 StmA s a
action0
  where
    go :: forall b.
          StmStack s b a
       -> Map TVarId (SomeTVar s)  -- set of vars read
       -> Map TVarId (SomeTVar s)  -- set of vars written
       -> [SomeTVar s]             -- vars written in order (no dups)
       -> [SomeTVar s]             -- vars created in order
       -> TVarId                   -- var fresh name supply
       -> StmA s b
       -> ST s (SimTrace c)
    go :: forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go !StmStack s b a
ctl !Map TVarId (SomeTVar s)
read !Map TVarId (SomeTVar s)
written ![SomeTVar s]
writtenSeq ![SomeTVar s]
createdSeq !TVarId
nextVid StmA s b
action = forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
localInvariant forall a b. (a -> b) -> a -> b
$
                                                       case StmA s b
action of
      ReturnStm b
x ->
        {-# SCC "execAtomically.go.ReturnStm" #-}
        case StmStack s b a
ctl of
        StmStack s b a
AtomicallyFrame -> do
          -- Trace each created TVar
          ![TraceValue]
ds  <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> Bool -> ST s TraceValue
traceTVarST TVar s a
tvar Bool
True) [SomeTVar s]
createdSeq
          -- Trace & commit each TVar
          ![TraceValue]
ds' <- forall k a. Map k a -> [a]
Map.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                    (\(SomeTVar TVar s a
tvar) -> do
                        TraceValue
tr <- forall s a. TVar s a -> Bool -> ST s TraceValue
traceTVarST TVar s a
tvar Bool
False
                        !()
_ <- forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar
                        -- Also assert the data invariant that outside a tx
                        -- the undo stack is empty:
                        [a]
undos <- forall s a. TVar s a -> ST s [a]
readTVarUndos TVar s a
tvar
                        forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
undos) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return TraceValue
tr
                    ) Map TVarId (SomeTVar s)
written

          -- Return the vars written, so readers can be unblocked
          StmTxResult s a -> ST s (SimTrace c)
k0 forall a b. (a -> b) -> a -> b
$ forall s a.
a
-> [SomeTVar s]
-> [SomeTVar s]
-> [SomeTVar s]
-> [Dynamic]
-> [ThreadLabel]
-> TVarId
-> StmTxResult s a
StmTxCommitted b
x (forall a. [a] -> [a]
reverse [SomeTVar s]
writtenSeq)
                                []
                                (forall a. [a] -> [a]
reverse [SomeTVar s]
createdSeq)
                                (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\TraceValue { Maybe tr
traceDynamic :: ()
traceDynamic :: Maybe tr
traceDynamic }
                                            -> forall a. Typeable a => a -> Dynamic
toDyn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe tr
traceDynamic)
                                          forall a b. (a -> b) -> a -> b
$ [TraceValue]
ds forall a. [a] -> [a] -> [a]
++ [TraceValue]
ds')
                                (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TraceValue -> Maybe ThreadLabel
traceString forall a b. (a -> b) -> a -> b
$ [TraceValue]
ds forall a. [a] -> [a] -> [a]
++ [TraceValue]
ds')
                                TVarId
nextVid

        BranchFrame BranchStmA s b
_b b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' -> do
          -- The branch has successfully completed the transaction. Hence,
          -- the alternative branch can be ignored.
          -- Commit the TVars written in this sub-transaction that are also
          -- in the written set of the outer transaction
          !()
_ <- forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar)
                          (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map TVarId (SomeTVar s)
written Map TVarId (SomeTVar s)
writtenOuter)
          -- Merge the written set of the inner with the outer
          let written' :: Map TVarId (SomeTVar s)
written'    = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TVarId (SomeTVar s)
written Map TVarId (SomeTVar s)
writtenOuter
              writtenSeq' :: [SomeTVar s]
writtenSeq' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(SomeTVar TVar s a
tvar) ->
                                      forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map TVarId (SomeTVar s)
writtenOuter)
                                    [SomeTVar s]
writtenSeq
                         forall a. [a] -> [a] -> [a]
++ [SomeTVar s]
writtenOuterSeq
              createdSeq' :: [SomeTVar s]
createdSeq' = [SomeTVar s]
createdSeq forall a. [a] -> [a] -> [a]
++ [SomeTVar s]
createdOuterSeq
          -- Skip the right hand alternative and continue with the k continuation
          forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written' [SomeTVar s]
writtenSeq' [SomeTVar s]
createdSeq' TVarId
nextVid (b -> StmA s b
k b
x)

      ThrowStm SomeException
e ->
        {-# SCC "execAtomically.go.ThrowStm" #-} do
        -- Rollback `TVar`s written since catch handler was installed
        !()
_ <- forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
        case StmStack s b a
ctl of
          StmStack s b a
AtomicallyFrame -> do
            StmTxResult s a -> ST s (SimTrace c)
k0 forall a b. (a -> b) -> a -> b
$ forall s a. [SomeTVar s] -> SomeException -> StmTxResult s a
StmTxAborted (forall k a. Map k a -> [a]
Map.elems Map TVarId (SomeTVar s)
read) (forall e. Exception e => e -> SomeException
toException SomeException
e)

          BranchFrame (CatchStmA SomeException -> StmA s b
h) b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' ->
            {-# SCC "execAtomically.go.BranchFrame" #-} do
            -- Execute the left side in a new frame with an empty written set.
            -- but preserve ones that were set prior to it, as specified in the
            -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.
            let ctl'' :: StmStack s b a
ctl'' = forall s a a c.
BranchStmA s a
-> (a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> StmStack s a c
-> StmStack s a c
BranchFrame forall s a. BranchStmA s a
NoOpStmA b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl'
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl'' Map TVarId (SomeTVar s)
read forall k a. Map k a
Map.empty [] [] TVarId
nextVid (SomeException -> StmA s b
h SomeException
e)

          BranchFrame (OrElseStmA StmA s b
_r) b -> StmA s b
_k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' ->
            {-# SCC "execAtomically.go.BranchFrame" #-} do
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq TVarId
nextVid (forall s a. SomeException -> StmA s a
ThrowStm SomeException
e)

          BranchFrame BranchStmA s b
NoOpStmA b -> StmA s b
_k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' ->
            {-# SCC "execAtomically.go.BranchFrame" #-} do
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq TVarId
nextVid (forall s a. SomeException -> StmA s a
ThrowStm SomeException
e)

      CatchStm StmA s a
a SomeException -> StmA s a
h a -> StmA s b
k ->
        {-# SCC "execAtomically.go.ThrowStm" #-} do
        -- Execute the catch handler with an empty written set.
        -- but preserve ones that were set prior to it, as specified in the
        -- [stm](https://hackage.haskell.org/package/stm/docs/Control-Monad-STM.html#v:catchSTM) package.
        let ctl' :: StmStack s a a
ctl' = forall s a a c.
BranchStmA s a
-> (a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> StmStack s a c
-> StmStack s a c
BranchFrame (forall s a. (SomeException -> StmA s a) -> BranchStmA s a
CatchStmA SomeException -> StmA s a
h) a -> StmA s b
k Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq StmStack s b a
ctl
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s a a
ctl' Map TVarId (SomeTVar s)
read forall k a. Map k a
Map.empty [] [] TVarId
nextVid StmA s a
a


      StmA s b
Retry ->
        {-# SCC "execAtomically.go.Retry" #-} do
          -- Always revert all the TVar writes for the retry
          !()
_ <- forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
          case StmStack s b a
ctl of
            StmStack s b a
AtomicallyFrame -> do
              -- Return vars read, so the thread can block on them
              StmTxResult s a -> ST s (SimTrace c)
k0 forall a b. (a -> b) -> a -> b
$! forall s a. [SomeTVar s] -> StmTxResult s a
StmTxBlocked forall a b. (a -> b) -> a -> b
$! forall k a. Map k a -> [a]
Map.elems Map TVarId (SomeTVar s)
read

            BranchFrame (OrElseStmA StmA s b
b) b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' ->
              {-# SCC "execAtomically.go.BranchFrame.OrElseStmA" #-} do
              -- Execute the orElse right hand with an empty written set
              let ctl'' :: StmStack s b a
ctl'' = forall s a a c.
BranchStmA s a
-> (a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> StmStack s a c
-> StmStack s a c
BranchFrame forall s a. BranchStmA s a
NoOpStmA b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl'
              forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl'' Map TVarId (SomeTVar s)
read forall k a. Map k a
Map.empty [] [] TVarId
nextVid StmA s b
b

            BranchFrame BranchStmA s b
_ b -> StmA s b
_k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq StmStack s b a
ctl' ->
              {-# SCC "execAtomically.go.BranchFrame" #-} do
              -- Retry makes sense only within a OrElse context. If it is a branch other than
              -- OrElse left side, then bubble up the `retry` to the frame above.
              -- Skip the continuation and propagate the retry into the outer frame
              -- using the written set for the outer frame
              forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq [SomeTVar s]
createdOuterSeq TVarId
nextVid forall s b. StmA s b
Retry

      OrElse StmA s a
a StmA s a
b a -> StmA s b
k ->
        {-# SCC "execAtomically.go.OrElse" #-} do
        -- Execute the left side in a new frame with an empty written set
        let ctl' :: StmStack s a a
ctl' = forall s a a c.
BranchStmA s a
-> (a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> StmStack s a c
-> StmStack s a c
BranchFrame (forall s a. StmA s a -> BranchStmA s a
OrElseStmA StmA s a
b) a -> StmA s b
k Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq StmStack s b a
ctl
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s a a
ctl' Map TVarId (SomeTVar s)
read forall k a. Map k a
Map.empty [] [] TVarId
nextVid StmA s a
a

      NewTVar !Maybe ThreadLabel
mbLabel x
x TVar s x -> StmA s b
k ->
        {-# SCC "execAtomically.go.NewTVar" #-} do
        !TVar s x
v <- forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid Maybe ThreadLabel
mbLabel x
x
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq (forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s x
v forall a. a -> [a] -> [a]
: [SomeTVar s]
createdSeq) (forall a. Enum a => a -> a
succ TVarId
nextVid) (TVar s x -> StmA s b
k TVar s x
v)

      LabelTVar !ThreadLabel
label TVar s a
tvar StmA s b
k ->
        {-# SCC "execAtomically.go.LabelTVar" #-} do
        !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a. TVar s a -> STRef s (Maybe ThreadLabel)
tvarLabel TVar s a
tvar) forall a b. (a -> b) -> a -> b
$! (forall a. a -> Maybe a
Just ThreadLabel
label)
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k

      TraceTVar TVar s a
tvar Maybe a -> a -> ST s TraceValue
f StmA s b
k ->
        {-# SCC "execAtomically.go.TraceTVar" #-} do
        !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef (forall s a.
TVar s a -> STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace TVar s a
tvar) (forall a. a -> Maybe a
Just Maybe a -> a -> ST s TraceValue
f)
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k

      ReadTVar TVar s a
v a -> StmA s b
k
        | forall s a. TVar s a -> TVarId
tvarId TVar s a
v forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TVarId (SomeTVar s)
read ->
            {-# SCC "execAtomically.go.ReadTVar" #-} do
            a
x <- forall s a. TVar s a -> ST s a
execReadTVar TVar s a
v
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid (a -> StmA s b
k a
x)
        | Bool
otherwise ->
            {-# SCC "execAtomically.go.ReadTVar" #-} do
            a
x <- forall s a. TVar s a -> ST s a
execReadTVar TVar s a
v
            let read' :: Map TVarId (SomeTVar s)
read' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. TVar s a -> TVarId
tvarId TVar s a
v) (forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v) Map TVarId (SomeTVar s)
read
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read' Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid (a -> StmA s b
k a
x)

      WriteTVar TVar s a
v a
x StmA s b
k
        | forall s a. TVar s a -> TVarId
tvarId TVar s a
v forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TVarId (SomeTVar s)
written ->
            {-# SCC "execAtomically.go.WriteTVar" #-} do
            !()
_ <- forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k
        | Bool
otherwise ->
            {-# SCC "execAtomically.go.WriteTVar" #-} do
            !()
_ <- forall s a. TVar s a -> ST s ()
saveTVar TVar s a
v
            !()
_ <- forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            let written' :: Map TVarId (SomeTVar s)
written' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. TVar s a -> TVarId
tvarId TVar s a
v) (forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v) Map TVarId (SomeTVar s)
written
            forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written' (forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v forall a. a -> [a] -> [a]
: [SomeTVar s]
writtenSeq) [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k

      SayStm ThreadLabel
msg StmA s b
k ->
        {-# SCC "execAtomically.go.SayStm" #-} do
        SimTrace c
trace <- forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (ThreadLabel -> SimEventType
EventSay ThreadLabel
msg) SimTrace c
trace

      OutputStm Dynamic
x StmA s b
k ->
        {-# SCC "execAtomically.go.OutputStm" #-} do
        SimTrace c
trace <- forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Time
-> ThreadId
-> Maybe ThreadLabel
-> SimEventType
-> SimTrace a
-> SimTrace a
SimTrace Time
time ThreadId
tid Maybe ThreadLabel
tlbl (Dynamic -> SimEventType
EventLog Dynamic
x) SimTrace c
trace

      LiftSTStm ST s a
st a -> StmA s b
k ->
        {-# SCC "schedule.LiftSTStm" #-} do
        a
x <- forall s a. ST s a -> ST s a
strictToLazyST ST s a
st
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid (a -> StmA s b
k a
x)

      FixStm x -> STM s x
f x -> StmA s b
k ->
        {-# SCC "execAtomically.go.FixStm" #-} do
        STRef s x
r <- forall a s. a -> ST s (STRef s a)
newSTRef (forall a e. Exception e => e -> a
throw NonTermination
NonTermination)
        x
x <- forall s a. ST s a -> ST s a
unsafeInterleaveST forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> ST s a
readSTRef STRef s x
r
        let k' :: StmA s b
k' = forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM (x -> STM s x
f x
x) forall a b. (a -> b) -> a -> b
$ \x
x' ->
                    forall s a b. ST s a -> (a -> StmA s b) -> StmA s b
LiftSTStm (forall s a. ST s a -> ST s a
lazyToStrictST (forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s x
r x
x')) (\() -> x -> StmA s b
k x
x')
        forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (SimTrace c)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq [SomeTVar s]
createdSeq TVarId
nextVid StmA s b
k'

      where
        localInvariant :: Bool
localInvariant =
            forall k a. Map k a -> Set k
Map.keysSet Map TVarId (SomeTVar s)
written
         forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> Set a
Set.fromList [ forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar | SomeTVar TVar s a
tvar <- [SomeTVar s]
writtenSeq ]


-- | Special case of 'execAtomically' supporting only var reads and writes
--
execAtomically' :: StmA s () -> ST s [SomeTVar s]
execAtomically' :: forall s. StmA s () -> ST s [SomeTVar s]
execAtomically' = forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go forall k a. Map k a
Map.empty
  where
    go :: Map TVarId (SomeTVar s)  -- set of vars written
       -> StmA s ()
       -> ST s [SomeTVar s]
    go :: forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go !Map TVarId (SomeTVar s)
written StmA s ()
action = case StmA s ()
action of
      ReturnStm () -> do
        !()
_ <- forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Map k a -> [a]
Map.elems Map TVarId (SomeTVar s)
written)
      ReadTVar TVar s a
v a -> StmA s ()
k  -> do
        a
x <- forall s a. TVar s a -> ST s a
execReadTVar TVar s a
v
        forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
written (a -> StmA s ()
k a
x)
      WriteTVar TVar s a
v a
x StmA s ()
k
        | forall s a. TVar s a -> TVarId
tvarId TVar s a
v forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TVarId (SomeTVar s)
written -> do
            !()
_ <- forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
written StmA s ()
k
        | Bool
otherwise -> do
            !()
_ <- forall s a. TVar s a -> ST s ()
saveTVar TVar s a
v
            !()
_ <- forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            let written' :: Map TVarId (SomeTVar s)
written' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall s a. TVar s a -> TVarId
tvarId TVar s a
v) (forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v) Map TVarId (SomeTVar s)
written
            forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
written' StmA s ()
k
      StmA s ()
_ -> forall a. (?callStack::CallStack) => ThreadLabel -> a
error ThreadLabel
"execAtomically': only for special case of reads and writes"


execNewTVar :: TVarId -> Maybe String -> a -> ST s (TVar s a)
execNewTVar :: forall a s. TVarId -> Maybe ThreadLabel -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid !Maybe ThreadLabel
mbLabel a
x = do
    !STRef s (Maybe ThreadLabel)
tvarLabel   <- forall a s. a -> ST s (STRef s a)
newSTRef Maybe ThreadLabel
mbLabel
    !STRef s a
tvarCurrent <- forall a s. a -> ST s (STRef s a)
newSTRef a
x
    !STRef s [a]
tvarUndo    <- forall a s. a -> ST s (STRef s a)
newSTRef forall a b. (a -> b) -> a -> b
$! []
    !STRef s ([ThreadId], Set ThreadId)
tvarBlocked <- forall a s. a -> ST s (STRef s a)
newSTRef ([], forall a. Set a
Set.empty)
    !STRef s VectorClock
tvarVClock  <- forall a s. a -> ST s (STRef s a)
newSTRef forall a b. (a -> b) -> a -> b
$! Map ThreadId Int -> VectorClock
VectorClock forall k a. Map k a
Map.empty
    !STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace   <- forall a s. a -> ST s (STRef s a)
newSTRef forall a b. (a -> b) -> a -> b
$! forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return TVar {tvarId :: TVarId
tvarId = TVarId
nextVid, STRef s (Maybe ThreadLabel)
tvarLabel :: STRef s (Maybe ThreadLabel)
tvarLabel :: STRef s (Maybe ThreadLabel)
tvarLabel,
                 STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo, STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked, STRef s VectorClock
tvarVClock :: STRef s VectorClock
tvarVClock :: STRef s VectorClock
tvarVClock,
                 STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace :: STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace :: STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace}


-- 'execReadTVar' is defined in `Control.Monad.IOSim.Type` and shared with /IOSimPOR/

execWriteTVar :: TVar s a -> a -> ST s ()
execWriteTVar :: forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent} = forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
tvarCurrent
{-# INLINE execWriteTVar #-}

execTryPutTMVar :: TMVar (IOSim s) a -> a -> ST s Bool
execTryPutTMVar :: forall s a. TMVar (IOSim s) a -> a -> ST s Bool
execTryPutTMVar (TMVar TVar (IOSim s) (Maybe a)
var) a
a = do
    Maybe a
v <- forall s a. TVar s a -> ST s a
execReadTVar TVar (IOSim s) (Maybe a)
var
    case Maybe a
v of
      Maybe a
Nothing -> forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar (IOSim s) (Maybe a)
var (forall a. a -> Maybe a
Just a
a)
              forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Just a
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
{-# INLINE execTryPutTMVar #-}

saveTVar :: TVar s a -> ST s ()
saveTVar :: forall s a. TVar s a -> ST s ()
saveTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
    -- push the current value onto the undo stack
    a
v  <- forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
    [a]
vs <- forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo (a
vforall a. a -> [a] -> [a]
:[a]
vs)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

revertTVar :: TVar s a -> ST s ()
revertTVar :: forall s a. TVar s a -> ST s ()
revertTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
    -- pop the undo stack, and revert the current value
    [a]
vs <- forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
tvarCurrent (forall a. [a] -> a
head [a]
vs)
    !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo    (forall a. [a] -> [a]
tail [a]
vs)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE revertTVar #-}

commitTVar :: TVar s a -> ST s ()
commitTVar :: forall s a. TVar s a -> ST s ()
commitTVar TVar{STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
    [a]
vs <- forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    -- pop the undo stack, leaving the current value unchanged
    !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo (forall a. [a] -> [a]
tail [a]
vs)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# INLINE commitTVar #-}

readTVarUndos :: TVar s a -> ST s [a]
readTVarUndos :: forall s a. TVar s a -> ST s [a]
readTVarUndos TVar{STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo

-- | Trace a 'TVar'.  It must be called only on 'TVar's that were new or
-- 'written.
traceTVarST :: TVar s a
            -> Bool -- true if it's a new 'TVar'
            -> ST s TraceValue
traceTVarST :: forall s a. TVar s a -> Bool -> ST s TraceValue
traceTVarST TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo, STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace :: STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace :: forall s a.
TVar s a -> STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace} Bool
new = do
    Maybe (Maybe a -> a -> ST s TraceValue)
mf <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Maybe (Maybe a -> a -> ST s TraceValue))
tvarTrace
    case Maybe (Maybe a -> a -> ST s TraceValue)
mf of
      Maybe (Maybe a -> a -> ST s TraceValue)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return TraceValue { traceDynamic :: Maybe ()
traceDynamic = (forall a. Maybe a
Nothing :: Maybe ())
                                   , traceString :: Maybe ThreadLabel
traceString = forall a. Maybe a
Nothing }
      Just Maybe a -> a -> ST s TraceValue
f  -> do
        [a]
vs <- forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
        a
v  <- forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
        case (Bool
new, [a]
vs) of
          (Bool
True, [a]
_) -> Maybe a -> a -> ST s TraceValue
f forall a. Maybe a
Nothing a
v
          (Bool
_, a
_:[a]
_)  -> Maybe a -> a -> ST s TraceValue
f (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [a]
vs) a
v
          (Bool, [a])
_         -> forall a. (?callStack::CallStack) => ThreadLabel -> a
error ThreadLabel
"traceTVarST: unexpected tvar state"



--
-- Blocking and unblocking on TVars
--

readTVarBlockedThreads :: TVar s a -> ST s [ThreadId]
readTVarBlockedThreads :: forall s a. TVar s a -> ST s [ThreadId]
readTVarBlockedThreads TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. STRef s a -> ST s a
readSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked

blockThreadOnTVar :: ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar :: forall s a. ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar ThreadId
tid TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = do
    ([ThreadId]
tids, Set ThreadId
tidsSet) <- forall s a. STRef s a -> ST s a
readSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ThreadId
tid forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set ThreadId
tidsSet) forall a b. (a -> b) -> a -> b
$ do
      let !tids' :: [ThreadId]
tids'    = ThreadId
tid forall a. a -> [a] -> [a]
: [ThreadId]
tids
          !tidsSet' :: Set ThreadId
tidsSet' = forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
tid Set ThreadId
tidsSet
      !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked ([ThreadId]
tids', Set ThreadId
tidsSet')
      forall (m :: * -> *) a. Monad m => a -> m a
return ()

unblockAllThreadsFromTVar :: TVar s a -> ST s ()
unblockAllThreadsFromTVar :: forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = do
    !()
_ <- forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked ([], forall a. Set a
Set.empty)
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | For each TVar written to in a transaction (in order) collect the threads
-- that blocked on each one (in order).
--
-- Also, for logging purposes, return an association between the threads and
-- the var writes that woke them.
--
threadsUnblockedByWrites :: [SomeTVar s]
                         -> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))
threadsUnblockedByWrites :: forall s.
[SomeTVar s]
-> ST s ([ThreadId], Map ThreadId (Set (Labelled TVarId)))
threadsUnblockedByWrites [SomeTVar s]
written = do
  ![(Labelled TVarId, [ThreadId])]
tidss <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
             [ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. TVar s a -> ST s (Labelled TVarId)
labelledTVarId TVar s a
tvar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s a. TVar s a -> ST s [ThreadId]
readTVarBlockedThreads TVar s a
tvar
             | SomeTVar TVar s a
tvar <- [SomeTVar s]
written ]
  -- Threads to wake up, in wake up order, annotated with the vars written that
  -- caused the unblocking.
  -- We reverse the individual lists because the tvarBlocked is used as a stack
  -- so it is in order of last written, LIFO, and we want FIFO behaviour.
  let !wakeup :: [ThreadId]
wakeup = forall a. Ord a => [a] -> [a]
ordNub [ ThreadId
tid | (Labelled TVarId
_vid, [ThreadId]
tids) <- [(Labelled TVarId, [ThreadId])]
tidss, ThreadId
tid <- forall a. [a] -> [a]
reverse [ThreadId]
tids ]
      wokeby :: Map ThreadId (Set (Labelled TVarId))
wokeby = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Ord a => Set a -> Set a -> Set a
Set.union
                                [ (ThreadId
tid, forall a. a -> Set a
Set.singleton Labelled TVarId
vid)
                                | (Labelled TVarId
vid, [ThreadId]
tids) <- [(Labelled TVarId, [ThreadId])]
tidss
                                , ThreadId
tid <- [ThreadId]
tids ]
  forall (m :: * -> *) a. Monad m => a -> m a
return ([ThreadId]
wakeup, Map ThreadId (Set (Labelled TVarId))
wokeby)

ordNub :: Ord a => [a] -> [a]
ordNub :: forall a. Ord a => [a] -> [a]
ordNub = forall {a}. Ord a => Set a -> [a] -> [a]
go forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
go !Set a
_ [] = []
    go !Set a
s (a
x:[a]
xs)
      | a
x forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s = Set a -> [a] -> [a]
go Set a
s [a]
xs
      | Bool
otherwise        = a
x forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs
{-# INLINE ordNub #-}