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

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

module Control.Monad.IOSim.Internal (
  IOSim (..),
  SimM,
  runIOSim,
  runSimTraceST,
  traceM,
  STM,
  STMSim,
  SimSTM,
  setCurrentTime,
  unshareClock,
  TimeoutException (..),
  EventlogEvent (..),
  EventlogMarker (..),
  ThreadId,
  ThreadLabel,
  LabeledThread (..),
  Trace (..),
  TraceEvent (..),
  liftST,
  execReadTVar
  ) where

import           Prelude hiding (read)

import           Data.Dynamic (Dynamic, toDyn)
import           Data.Foldable (traverse_)
import qualified Data.List as List
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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.Typeable (Typeable)

import           Control.Applicative (Alternative (..))
import           Control.Exception (ErrorCall (..), assert,
                     asyncExceptionFromException, asyncExceptionToException)
import           Control.Monad (MonadPlus, join)
import qualified System.IO.Error as IO.Error (userError)

import           Control.Monad (when)
import           Control.Monad.ST.Lazy
import           Control.Monad.ST.Lazy.Unsafe (unsafeIOToST)
import qualified Control.Monad.ST.Strict as StrictST
import           Data.STRef.Lazy

import qualified Control.Monad.Catch as Exceptions
import qualified Control.Monad.Fail as Fail

import           Control.Monad.Class.MonadAsync hiding (Async)
import qualified Control.Monad.Class.MonadAsync as MonadAsync
import           Control.Monad.Class.MonadEventlog
import           Control.Monad.Class.MonadFork hiding (ThreadId)
import qualified Control.Monad.Class.MonadFork as MonadFork
import           Control.Monad.Class.MonadSay
import           Control.Monad.Class.MonadST
import           Control.Monad.Class.MonadSTM hiding (STM, TVar)
import qualified Control.Monad.Class.MonadSTM as MonadSTM
import           Control.Monad.Class.MonadThrow as MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer

{-# ANN module "HLint: ignore Use readTVarIO" #-}
newtype IOSim s a = IOSim { IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim :: forall r. (a -> SimA s r) -> SimA s r }

type SimM s = IOSim s
{-# DEPRECATED SimM "Use IOSim" #-}

runIOSim :: IOSim s a -> SimA s a
runIOSim :: IOSim s a -> SimA s a
runIOSim (IOSim forall r. (a -> SimA s r) -> SimA s r
k) = (a -> SimA s a) -> SimA s a
forall r. (a -> SimA s r) -> SimA s r
k a -> SimA s a
forall a s. a -> SimA s a
Return

traceM :: Typeable a => a -> IOSim s ()
traceM :: a -> IOSim s ()
traceM a
x = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> Dynamic -> SimA s r -> SimA s r
forall s b. Dynamic -> SimA s b -> SimA s b
Output (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) (() -> SimA s r
k ())

data SimA s a where
  Return       :: a -> SimA s a

  Say          :: String -> SimA s b -> SimA s b
  Output       :: Dynamic -> SimA s b -> SimA s b

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

  GetMonoTime  :: (Time    -> SimA s b) -> SimA s b
  GetWallTime  :: (UTCTime -> SimA s b) -> SimA s b
  SetWallTime  ::  UTCTime -> SimA s b  -> SimA s b
  UnshareClock :: SimA s b -> SimA s b

  NewTimeout   :: DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
  UpdateTimeout:: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
  CancelTimeout:: Timeout (IOSim s) -> SimA s b -> SimA s b

  Throw        :: SomeException -> SimA s a
  Catch        :: Exception e =>
                  SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
  Evaluate     :: a -> (a -> SimA s b) -> SimA s b

  Fork         :: IOSim s () -> (ThreadId -> SimA s b) -> SimA s b
  GetThreadId  :: (ThreadId -> SimA s b) -> SimA s b
  LabelThread  :: ThreadId -> String -> SimA s b -> SimA s b

  Atomically   :: STM  s a -> (a -> SimA s b) -> SimA s b

  ThrowTo      :: SomeException -> ThreadId -> SimA s a -> SimA s a
  SetMaskState :: MaskingState  -> IOSim s a -> (a -> SimA s b) -> SimA s b
  GetMaskState :: (MaskingState -> SimA s b) -> SimA s b


newtype STM s a = STM { STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM :: forall r. (a -> StmA s r) -> StmA s r }

runSTM :: STM s a -> StmA s a
runSTM :: STM s a -> StmA s a
runSTM (STM forall r. (a -> StmA s r) -> StmA s r
k) = (a -> StmA s a) -> StmA s a
forall r. (a -> StmA s r) -> StmA s r
k a -> StmA s a
forall a s. a -> StmA s a
ReturnStm

data StmA s a where
  ReturnStm    :: a -> StmA s a
  ThrowStm     :: SomeException -> StmA s a

  NewTVar      :: x -> (TVar s x -> StmA s b) -> StmA s b
  ReadTVar     :: TVar s a -> (a -> StmA s b) -> StmA s b
  WriteTVar    :: TVar s a ->  a -> StmA s b  -> StmA s b
  Retry        :: StmA s b
  OrElse       :: StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b

-- Exported type
type STMSim = STM

type SimSTM = STM
{-# DEPRECATED SimSTM "Use STMSim" #-}

data MaskingState = Unmasked | MaskedInterruptible | MaskedUninterruptible
  deriving (MaskingState -> MaskingState -> Bool
(MaskingState -> MaskingState -> Bool)
-> (MaskingState -> MaskingState -> Bool) -> Eq MaskingState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MaskingState -> MaskingState -> Bool
$c/= :: MaskingState -> MaskingState -> Bool
== :: MaskingState -> MaskingState -> Bool
$c== :: MaskingState -> MaskingState -> Bool
Eq, Eq MaskingState
Eq MaskingState
-> (MaskingState -> MaskingState -> Ordering)
-> (MaskingState -> MaskingState -> Bool)
-> (MaskingState -> MaskingState -> Bool)
-> (MaskingState -> MaskingState -> Bool)
-> (MaskingState -> MaskingState -> Bool)
-> (MaskingState -> MaskingState -> MaskingState)
-> (MaskingState -> MaskingState -> MaskingState)
-> Ord MaskingState
MaskingState -> MaskingState -> Bool
MaskingState -> MaskingState -> Ordering
MaskingState -> MaskingState -> MaskingState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MaskingState -> MaskingState -> MaskingState
$cmin :: MaskingState -> MaskingState -> MaskingState
max :: MaskingState -> MaskingState -> MaskingState
$cmax :: MaskingState -> MaskingState -> MaskingState
>= :: MaskingState -> MaskingState -> Bool
$c>= :: MaskingState -> MaskingState -> Bool
> :: MaskingState -> MaskingState -> Bool
$c> :: MaskingState -> MaskingState -> Bool
<= :: MaskingState -> MaskingState -> Bool
$c<= :: MaskingState -> MaskingState -> Bool
< :: MaskingState -> MaskingState -> Bool
$c< :: MaskingState -> MaskingState -> Bool
compare :: MaskingState -> MaskingState -> Ordering
$ccompare :: MaskingState -> MaskingState -> Ordering
$cp1Ord :: Eq MaskingState
Ord, Int -> MaskingState -> ShowS
[MaskingState] -> ShowS
MaskingState -> String
(Int -> MaskingState -> ShowS)
-> (MaskingState -> String)
-> ([MaskingState] -> ShowS)
-> Show MaskingState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MaskingState] -> ShowS
$cshowList :: [MaskingState] -> ShowS
show :: MaskingState -> String
$cshow :: MaskingState -> String
showsPrec :: Int -> MaskingState -> ShowS
$cshowsPrec :: Int -> MaskingState -> ShowS
Show)

--
-- Monad class instances
--

instance Functor (IOSim s) where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> IOSim s a -> IOSim s b
fmap a -> b
f = \IOSim s a
d -> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
d (b -> SimA s r
k (b -> SimA s r) -> (a -> b) -> a -> SimA s r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (IOSim s) where
    {-# INLINE pure #-}
    pure :: a -> IOSim s a
pure = \a
x -> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> a -> SimA s r
k a
x

    {-# INLINE (<*>) #-}
    <*> :: IOSim s (a -> b) -> IOSim s a -> IOSim s b
(<*>) = \IOSim s (a -> b)
df IOSim s a
dx -> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k ->
                        IOSim s (a -> b) -> ((a -> b) -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s (a -> b)
df (\a -> b
f -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dx (\a
x -> b -> SimA s r
k (a -> b
f a
x)))

    {-# INLINE (*>) #-}
    *> :: IOSim s a -> IOSim s b -> IOSim s b
(*>) = \IOSim s a
dm IOSim s b
dn -> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
_ -> IOSim s b -> (b -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s b
dn b -> SimA s r
k)

instance Monad (IOSim s) where
    return :: a -> IOSim s a
return = a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: IOSim s a -> (a -> IOSim s b) -> IOSim s b
(>>=) = \IOSim s a
dm a -> IOSim s b
f -> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b)
-> (forall r. (b -> SimA s r) -> SimA s r) -> IOSim s b
forall a b. (a -> b) -> a -> b
$ \b -> SimA s r
k -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim IOSim s a
dm (\a
m -> IOSim s b -> (b -> SimA s r) -> SimA s r
forall s a. IOSim s a -> forall r. (a -> SimA s r) -> SimA s r
unIOSim (a -> IOSim s b
f a
m) b -> SimA s r
k)

    {-# INLINE (>>) #-}
    >> :: IOSim s a -> IOSim s b -> IOSim s b
(>>) = IOSim s a -> IOSim s b -> IOSim s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance Fail.MonadFail (IOSim s) where
  fail :: String -> IOSim s a
fail String
msg = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> SomeException -> SimA s r
forall s a. SomeException -> SimA s a
Throw (IOError -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> IOError
IO.Error.userError String
msg))


instance Functor (STM s) where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> STM s a -> STM s b
fmap a -> b
f = \STM s a
d -> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
d (b -> StmA s r
k (b -> StmA s r) -> (a -> b) -> a -> StmA s r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative (STM s) where
    {-# INLINE pure #-}
    pure :: a -> STM s a
pure = \a
x -> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> a -> StmA s r
k a
x

    {-# INLINE (<*>) #-}
    <*> :: STM s (a -> b) -> STM s a -> STM s b
(<*>) = \STM s (a -> b)
df STM s a
dx -> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k ->
                        STM s (a -> b) -> ((a -> b) -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s (a -> b)
df (\a -> b
f -> STM s a -> (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dx (\a
x -> b -> StmA s r
k (a -> b
f a
x)))

    {-# INLINE (*>) #-}
    *> :: STM s a -> STM s b -> STM s b
(*>) = \STM s a
dm STM s b
dn -> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
_ -> STM s b -> (b -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s b
dn b -> StmA s r
k)

instance Monad (STM s) where
    return :: a -> STM s a
return = a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    >>= :: STM s a -> (a -> STM s b) -> STM s b
(>>=) = \STM s a
dm a -> STM s b
f -> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (b -> StmA s r) -> StmA s r) -> STM s b)
-> (forall r. (b -> StmA s r) -> StmA s r) -> STM s b
forall a b. (a -> b) -> a -> b
$ \b -> StmA s r
k -> STM s a -> (a -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM STM s a
dm (\a
m -> STM s b -> (b -> StmA s r) -> StmA s r
forall s a. STM s a -> forall r. (a -> StmA s r) -> StmA s r
unSTM (a -> STM s b
f a
m) b -> StmA s r
k)

    {-# INLINE (>>) #-}
    >> :: STM s a -> STM s b -> STM s b
(>>) = STM s a -> STM s b -> STM s b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !(MIN_VERSION_base(4,13,0))
    fail = Fail.fail
#endif

instance Fail.MonadFail (STM s) where
  fail :: String -> STM s a
fail String
msg = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> SomeException -> StmA s r
forall s a. SomeException -> StmA s a
ThrowStm (ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
msg))

instance Alternative (STM s) where
    empty :: STM s a
empty = STM s a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
    <|> :: STM s a -> STM s a -> STM s a
(<|>) = STM s a -> STM s a -> STM s a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a -> stm a -> stm a
orElse

instance MonadPlus (STM s) where


instance MonadSay (IOSim s) where
  say :: String -> IOSim s ()
say String
msg = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> String -> SimA s r -> SimA s r
forall s b. String -> SimA s b -> SimA s b
Say String
msg (() -> SimA s r
k ())

instance MonadThrow (IOSim s) where
  throwIO :: e -> IOSim s a
throwIO e
e = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
_ -> SomeException -> SimA s r
forall s a. SomeException -> SimA s a
Throw (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)

instance MonadEvaluate (IOSim s) where
  evaluate :: a -> IOSim s a
evaluate a
a = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> a -> (a -> SimA s r) -> SimA s r
forall a s b. a -> (a -> SimA s b) -> SimA s b
Evaluate a
a a -> SimA s r
k

instance Exceptions.MonadThrow (IOSim s) where
  throwM :: e -> IOSim s a
throwM = e -> IOSim s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MonadThrow.throwIO

instance MonadThrow (STM s) where
  throwIO :: e -> STM s a
throwIO e
e = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> SomeException -> StmA s r
forall s a. SomeException -> StmA s a
ThrowStm (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)

  -- Since these involve re-throwing the exception and we don't provide
  -- CatchSTM at all, then we can get away with trivial versions:
  bracket :: STM s a -> (a -> STM s b) -> (a -> STM s c) -> STM s c
bracket STM s a
before a -> STM s b
after a -> STM s c
thing = do
    a
a <- STM s a
before
    c
r <- a -> STM s c
thing a
a
    b
_ <- a -> STM s b
after a
a
    c -> STM s c
forall (m :: * -> *) a. Monad m => a -> m a
return c
r

  finally :: STM s a -> STM s b -> STM s a
finally STM s a
thing STM s b
after = do
    a
r <- STM s a
thing
    b
_ <- STM s b
after
    a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

instance Exceptions.MonadThrow (STM s) where
  throwM :: e -> STM s a
throwM = e -> STM s a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
MonadThrow.throwIO

instance MonadCatch (IOSim s) where
  catch :: IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch IOSim s a
action e -> IOSim s a
handler =
    (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> SimA s a -> (e -> SimA s a) -> (a -> SimA s r) -> SimA s r
forall e s a b.
Exception e =>
SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
Catch (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action) (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim (IOSim s a -> SimA s a) -> (e -> IOSim s a) -> e -> SimA s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IOSim s a
handler) a -> SimA s r
k

instance Exceptions.MonadCatch (IOSim s) where
  catch :: IOSim s a -> (e -> IOSim s a) -> IOSim s a
catch = IOSim s a -> (e -> IOSim s a) -> IOSim s a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
MonadThrow.catch

instance MonadMask (IOSim s) where
  mask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
mask (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action = do
      MaskingState
b <- IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingState
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
block (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
blockUninterruptible

  uninterruptibleMask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
uninterruptibleMask (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action = do
      MaskingState
b <- IOSim s MaskingState
forall s. IOSim s MaskingState
getMaskingState
      case MaskingState
b of
        MaskingState
Unmasked              -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
blockUninterruptible (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock
        MaskingState
MaskedInterruptible   -> IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
blockUninterruptible (IOSim s b -> IOSim s b) -> IOSim s b -> IOSim s b
forall a b. (a -> b) -> a -> b
$ (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
block
        MaskingState
MaskedUninterruptible -> (forall a. IOSim s a -> IOSim s a) -> IOSim s b
action forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
blockUninterruptible

instance Exceptions.MonadMask (IOSim s) where
  mask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
mask                = ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.mask
  uninterruptibleMask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
uninterruptibleMask = ((forall a. IOSim s a -> IOSim s a) -> IOSim s b) -> IOSim s b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
MonadThrow.uninterruptibleMask

  generalBracket :: IOSim s a
-> (a -> ExitCase b -> IOSim s c)
-> (a -> IOSim s b)
-> IOSim s (b, c)
generalBracket IOSim s a
acquire a -> ExitCase b -> IOSim s c
release a -> IOSim s b
use =
    ((forall a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
-> IOSim s (b, c)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
 -> IOSim s (b, c))
-> ((forall a. IOSim s a -> IOSim s a) -> IOSim s (b, c))
-> IOSim s (b, c)
forall a b. (a -> b) -> a -> b
$ \forall a. IOSim s a -> IOSim s a
unmasked -> do
      a
resource <- IOSim s a
acquire
      b
b <- IOSim s b -> IOSim s b
forall a. IOSim s a -> IOSim s a
unmasked (a -> IOSim s b
use a
resource) IOSim s b -> (SomeException -> IOSim s b) -> IOSim s b
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \SomeException
e -> do
        c
_ <- a -> ExitCase b -> IOSim s c
release a
resource (SomeException -> ExitCase b
forall a. SomeException -> ExitCase a
Exceptions.ExitCaseException SomeException
e)
        SomeException -> IOSim s b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
      c
c <- a -> ExitCase b -> IOSim s c
release a
resource (b -> ExitCase b
forall a. a -> ExitCase a
Exceptions.ExitCaseSuccess b
b)
      (b, c) -> IOSim s (b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, c
c)


getMaskingState :: IOSim s MaskingState
unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a

getMaskingState :: IOSim s MaskingState
getMaskingState        = (forall r. (MaskingState -> SimA s r) -> SimA s r)
-> IOSim s MaskingState
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim  forall r. (MaskingState -> SimA s r) -> SimA s r
forall s b. (MaskingState -> SimA s b) -> SimA s b
GetMaskState
unblock :: IOSim s a -> IOSim s a
unblock              IOSim s a
a = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
Unmasked IOSim s a
a)
block :: IOSim s a -> IOSim s a
block                IOSim s a
a = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
MaskedInterruptible IOSim s a
a)
blockUninterruptible :: IOSim s a -> IOSim s a
blockUninterruptible IOSim s a
a = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim (MaskingState -> IOSim s a -> (a -> SimA s r) -> SimA s r
forall s a b.
MaskingState -> IOSim s a -> (a -> SimA s b) -> SimA s b
SetMaskState MaskingState
MaskedUninterruptible IOSim s a
a)

instance MonadThread (IOSim s) where
  type ThreadId (IOSim s) = ThreadId
  myThreadId :: IOSim s (ThreadId (IOSim s))
myThreadId       = (forall r. (ThreadId -> SimA s r) -> SimA s r) -> IOSim s ThreadId
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId -> SimA s r) -> SimA s r)
 -> IOSim s ThreadId)
-> (forall r. (ThreadId -> SimA s r) -> SimA s r)
-> IOSim s ThreadId
forall a b. (a -> b) -> a -> b
$ \ThreadId -> SimA s r
k -> (ThreadId -> SimA s r) -> SimA s r
forall s b. (ThreadId -> SimA s b) -> SimA s b
GetThreadId ThreadId -> SimA s r
k
  labelThread :: ThreadId (IOSim s) -> String -> IOSim s ()
labelThread ThreadId (IOSim s)
t String
l  = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> ThreadId -> String -> SimA s r -> SimA s r
forall s b. ThreadId -> String -> SimA s b -> SimA s b
LabelThread ThreadId (IOSim s)
ThreadId
t String
l (() -> SimA s r
k ())

instance MonadFork (IOSim s) where
  forkIO :: IOSim s () -> IOSim s (ThreadId (IOSim s))
forkIO IOSim s ()
task        = (forall r. (ThreadId -> SimA s r) -> SimA s r) -> IOSim s ThreadId
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (ThreadId -> SimA s r) -> SimA s r)
 -> IOSim s ThreadId)
-> (forall r. (ThreadId -> SimA s r) -> SimA s r)
-> IOSim s ThreadId
forall a b. (a -> b) -> a -> b
$ \ThreadId -> SimA s r
k -> IOSim s () -> (ThreadId -> SimA s r) -> SimA s r
forall s b. IOSim s () -> (ThreadId -> SimA s b) -> SimA s b
Fork IOSim s ()
task ThreadId -> SimA s r
k
  forkIOWithUnmask :: ((forall a. IOSim s a -> IOSim s a) -> IOSim s ())
-> IOSim s (ThreadId (IOSim s))
forkIOWithUnmask (forall a. IOSim s a -> IOSim s a) -> IOSim s ()
f = IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO ((forall a. IOSim s a -> IOSim s a) -> IOSim s ()
f forall a. IOSim s a -> IOSim s a
forall s a. IOSim s a -> IOSim s a
unblock)
  throwTo :: ThreadId (IOSim s) -> e -> IOSim s ()
throwTo ThreadId (IOSim s)
tid e
e      = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SomeException -> ThreadId -> SimA s r -> SimA s r
forall s a. SomeException -> ThreadId -> SimA s a -> SimA s a
ThrowTo (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) ThreadId (IOSim s)
ThreadId
tid (() -> SimA s r
k ())

instance MonadSTMTx (STM s) where
  type TVar_      (STM s) = TVar s
  type TMVar_     (STM s) = TMVarDefault (IOSim s)
  type TQueue_    (STM s) = TQueueDefault (IOSim s)
  type TBQueue_   (STM s) = TBQueueDefault (IOSim s)

  newTVar :: a -> STM s (TVar_ (STM s) a)
newTVar         a
x = (forall r. (TVar s a -> StmA s r) -> StmA s r) -> STM s (TVar s a)
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (TVar s a -> StmA s r) -> StmA s r)
 -> STM s (TVar s a))
-> (forall r. (TVar s a -> StmA s r) -> StmA s r)
-> STM s (TVar s a)
forall a b. (a -> b) -> a -> b
$ \TVar s a -> StmA s r
k -> a -> (TVar s a -> StmA s r) -> StmA s r
forall x s b. x -> (TVar s x -> StmA s b) -> StmA s b
NewTVar a
x TVar s a -> StmA s r
k
  readTVar :: TVar_ (STM s) a -> STM s a
readTVar   TVar_ (STM s) a
tvar   = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> TVar s a -> (a -> StmA s r) -> StmA s r
forall s a b. TVar s a -> (a -> StmA s b) -> StmA s b
ReadTVar TVar_ (STM s) a
TVar s a
tvar a -> StmA s r
k
  writeTVar :: TVar_ (STM s) a -> a -> STM s ()
writeTVar  TVar_ (STM s) a
tvar a
x = (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (() -> StmA s r) -> StmA s r) -> STM s ())
-> (forall r. (() -> StmA s r) -> StmA s r) -> STM s ()
forall a b. (a -> b) -> a -> b
$ \() -> StmA s r
k -> TVar s a -> a -> StmA s r -> StmA s r
forall s a b. TVar s a -> a -> StmA s b -> StmA s b
WriteTVar TVar_ (STM s) a
TVar s a
tvar a
x (() -> StmA s r
k ())
  retry :: STM s a
retry             = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
_ -> StmA s r
forall s b. StmA s b
Retry
  orElse :: STM s a -> STM s a -> STM s a
orElse        STM s a
a STM s a
b = (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall s a. (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
STM ((forall r. (a -> StmA s r) -> StmA s r) -> STM s a)
-> (forall r. (a -> StmA s r) -> StmA s r) -> STM s a
forall a b. (a -> b) -> a -> b
$ \a -> StmA s r
k -> StmA s a -> StmA s a -> (a -> StmA s r) -> StmA s r
forall s a b. StmA s a -> StmA s a -> (a -> StmA s b) -> StmA s b
OrElse (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM s a
a) (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM s a
b) a -> StmA s r
k

  newTMVar :: a -> STM s (TMVar_ (STM s) a)
newTMVar          = a -> STM s (TMVar_ (STM s) a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TMVarDefault m a)
newTMVarDefault
  newEmptyTMVar :: STM s (TMVar_ (STM s) a)
newEmptyTMVar     = STM s (TMVar_ (STM s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TMVarDefault m a)
newEmptyTMVarDefault
  takeTMVar :: TMVar_ (STM s) a -> STM s a
takeTMVar         = TMVar_ (STM s) a -> STM s a
forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
takeTMVarDefault
  tryTakeTMVar :: TMVar_ (STM s) a -> STM s (Maybe a)
tryTakeTMVar      = TMVar_ (STM s) a -> STM s (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
tryTakeTMVarDefault
  putTMVar :: TMVar_ (STM s) a -> a -> STM s ()
putTMVar          = TMVar_ (STM s) a -> a -> STM s ()
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m ()
putTMVarDefault
  tryPutTMVar :: TMVar_ (STM s) a -> a -> STM s Bool
tryPutTMVar       = TMVar_ (STM s) a -> a -> STM s Bool
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m Bool
tryPutTMVarDefault
  readTMVar :: TMVar_ (STM s) a -> STM s a
readTMVar         = TMVar_ (STM s) a -> STM s a
forall (m :: * -> *) a. MonadSTM m => TMVarDefault m a -> STM m a
readTMVarDefault
  tryReadTMVar :: TMVar_ (STM s) a -> STM s (Maybe a)
tryReadTMVar      = TMVar_ (STM s) a -> STM s (Maybe a)
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m (Maybe a)
tryReadTMVarDefault
  swapTMVar :: TMVar_ (STM s) a -> a -> STM s a
swapTMVar         = TMVar_ (STM s) a -> a -> STM s a
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> a -> STM m a
swapTMVarDefault
  isEmptyTMVar :: TMVar_ (STM s) a -> STM s Bool
isEmptyTMVar      = TMVar_ (STM s) a -> STM s Bool
forall (m :: * -> *) a.
MonadSTM m =>
TMVarDefault m a -> STM m Bool
isEmptyTMVarDefault

  newTQueue :: STM s (TQueue_ (STM s) a)
newTQueue         = STM s (TQueue_ (STM s) a)
forall (m :: * -> *) a. MonadSTM m => STM m (TQueueDefault m a)
newTQueueDefault
  readTQueue :: TQueue_ (STM s) a -> STM s a
readTQueue        = TQueue_ (STM s) a -> STM s a
forall (m :: * -> *) a. MonadSTM m => TQueueDefault m a -> STM m a
readTQueueDefault
  tryReadTQueue :: TQueue_ (STM s) a -> STM s (Maybe a)
tryReadTQueue     = TQueue_ (STM s) a -> STM s (Maybe a)
forall (m :: * -> *) a.
MonadSTMTx (STM m) =>
TQueueDefault m a -> STM m (Maybe a)
tryReadTQueueDefault
  writeTQueue :: TQueue_ (STM s) a -> a -> STM s ()
writeTQueue       = TQueue_ (STM s) a -> a -> STM s ()
forall (m :: * -> *) a.
MonadSTM m =>
TQueueDefault m a -> a -> STM m ()
writeTQueueDefault
  isEmptyTQueue :: TQueue_ (STM s) a -> STM s Bool
isEmptyTQueue     = TQueue_ (STM s) a -> STM s Bool
forall (m :: * -> *) a.
MonadSTMTx (STM m) =>
TQueueDefault m a -> STM m Bool
isEmptyTQueueDefault

  newTBQueue :: Natural -> STM s (TBQueue_ (STM s) a)
newTBQueue        = Natural -> STM s (TBQueue_ (STM s) a)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (TBQueueDefault m a)
newTBQueueDefault
  readTBQueue :: TBQueue_ (STM s) a -> STM s a
readTBQueue       = TBQueue_ (STM s) a -> STM s a
forall (m :: * -> *) a. MonadSTM m => TBQueueDefault m a -> STM m a
readTBQueueDefault
  tryReadTBQueue :: TBQueue_ (STM s) a -> STM s (Maybe a)
tryReadTBQueue    = TBQueue_ (STM s) a -> STM s (Maybe a)
forall (m :: * -> *) a.
MonadSTMTx (STM m) =>
TBQueueDefault m a -> STM m (Maybe a)
tryReadTBQueueDefault
  flushTBQueue :: TBQueue_ (STM s) a -> STM s [a]
flushTBQueue      = TBQueue_ (STM s) a -> STM s [a]
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m [a]
flushTBQueueDefault
  writeTBQueue :: TBQueue_ (STM s) a -> a -> STM s ()
writeTBQueue      = TBQueue_ (STM s) a -> a -> STM s ()
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> a -> STM m ()
writeTBQueueDefault
  lengthTBQueue :: TBQueue_ (STM s) a -> STM s Natural
lengthTBQueue     = TBQueue_ (STM s) a -> STM s Natural
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Natural
lengthTBQueueDefault
  isEmptyTBQueue :: TBQueue_ (STM s) a -> STM s Bool
isEmptyTBQueue    = TBQueue_ (STM s) a -> STM s Bool
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isEmptyTBQueueDefault
  isFullTBQueue :: TBQueue_ (STM s) a -> STM s Bool
isFullTBQueue     = TBQueue_ (STM s) a -> STM s Bool
forall (m :: * -> *) a.
MonadSTM m =>
TBQueueDefault m a -> STM m Bool
isFullTBQueueDefault

instance MonadSTM (IOSim s) where
  type STM       (IOSim s) = STM s

  atomically :: STM (IOSim s) a -> IOSim s a
atomically STM (IOSim s) a
action = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> STM s a -> (a -> SimA s r) -> SimA s r
forall s a b. STM s a -> (a -> SimA s b) -> SimA s b
Atomically STM (IOSim s) a
STM s a
action a -> SimA s r
k

  newTMVarIO :: a -> IOSim s (TMVar (IOSim s) a)
newTMVarIO        = a -> IOSim s (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVarDefault m a)
newTMVarIODefault
  newEmptyTMVarIO :: IOSim s (TMVar (IOSim s) a)
newEmptyTMVarIO   = IOSim s (TMVar (IOSim s) a)
forall (m :: * -> *) a. MonadSTM m => m (TMVarDefault m a)
newEmptyTMVarIODefault

data Async s a = Async !ThreadId (STM s (Either SomeException a))

instance Eq (Async s a) where
    Async ThreadId
tid STM s (Either SomeException a)
_ == :: Async s a -> Async s a -> Bool
== Async ThreadId
tid' STM s (Either SomeException a)
_ = ThreadId
tid ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid'

instance Ord (Async s a) where
    compare :: Async s a -> Async s a -> Ordering
compare (Async ThreadId
tid STM s (Either SomeException a)
_) (Async ThreadId
tid' STM s (Either SomeException a)
_) = ThreadId -> ThreadId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ThreadId
tid ThreadId
tid'

instance Functor (Async s) where
  fmap :: (a -> b) -> Async s a -> Async s b
fmap a -> b
f (Async ThreadId
tid STM s (Either SomeException a)
a) = ThreadId -> STM s (Either SomeException b) -> Async s b
forall s a. ThreadId -> STM s (Either SomeException a) -> Async s a
Async ThreadId
tid ((a -> b) -> Either SomeException a -> Either SomeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either SomeException a -> Either SomeException b)
-> STM s (Either SomeException a) -> STM s (Either SomeException b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException a)
a)

instance MonadAsyncSTM (Async s) (STM s) where
  waitCatchSTM :: Async s a -> STM s (Either SomeException a)
waitCatchSTM (Async ThreadId
_ STM s (Either SomeException a)
w) = STM s (Either SomeException a)
w
  pollSTM :: Async s a -> STM s (Maybe (Either SomeException a))
pollSTM      (Async ThreadId
_ STM s (Either SomeException a)
w) = (Either SomeException a -> Maybe (Either SomeException a)
forall a. a -> Maybe a
Just (Either SomeException a -> Maybe (Either SomeException a))
-> STM s (Either SomeException a)
-> STM s (Maybe (Either SomeException a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM s (Either SomeException a)
w) STM s (Maybe (Either SomeException a))
-> STM s (Maybe (Either SomeException a))
-> STM s (Maybe (Either SomeException a))
forall (stm :: * -> *) a. MonadSTMTx stm => stm a -> stm a -> stm a
`orElse` Maybe (Either SomeException a)
-> STM s (Maybe (Either SomeException a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either SomeException a)
forall a. Maybe a
Nothing

instance MonadAsync (IOSim s) where
  type Async (IOSim s) = Async s

  async :: IOSim s a -> IOSim s (Async (IOSim s) a)
async IOSim s a
action = do
    TMVarDefault (IOSim s) (Either SomeException a)
var <- IOSim s (TMVarDefault (IOSim s) (Either SomeException a))
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
newEmptyTMVarIO
    ThreadId
tid <- ((forall b. IOSim s b -> IOSim s b) -> IOSim s ThreadId)
-> IOSim s ThreadId
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall b. IOSim s b -> IOSim s b) -> IOSim s ThreadId)
 -> IOSim s ThreadId)
-> ((forall b. IOSim s b -> IOSim s b) -> IOSim s ThreadId)
-> IOSim s ThreadId
forall a b. (a -> b) -> a -> b
$ \forall b. IOSim s b -> IOSim s b
restore ->
             IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (IOSim s () -> IOSim s (ThreadId (IOSim s)))
-> IOSim s () -> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ IOSim s a -> IOSim s (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IOSim s a -> IOSim s a
forall b. IOSim s b -> IOSim s b
restore IOSim s a
action) IOSim s (Either SomeException a)
-> (Either SomeException a -> IOSim s ()) -> IOSim s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM s () -> IOSim s ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM s () -> IOSim s ())
-> (Either SomeException a -> STM s ())
-> Either SomeException a
-> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar_ (STM s) (Either SomeException a)
-> Either SomeException a -> STM s ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TMVar_ stm a -> a -> stm ()
putTMVar TMVar_ (STM s) (Either SomeException a)
TMVarDefault (IOSim s) (Either SomeException a)
var
    Async s a -> IOSim s (Async s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId -> STM s (Either SomeException a) -> Async s a
forall s a. ThreadId -> STM s (Either SomeException a) -> Async s a
Async ThreadId
tid (TMVar_ (STM s) (Either SomeException a)
-> STM s (Either SomeException a)
forall (stm :: * -> *) a. MonadSTMTx stm => TMVar_ stm a -> stm a
readTMVar TMVar_ (STM s) (Either SomeException a)
TMVarDefault (IOSim s) (Either SomeException a)
var))

  asyncThreadId :: Proxy (IOSim s) -> Async (IOSim s) a -> ThreadId (IOSim s)
asyncThreadId Proxy (IOSim s)
_proxy (Async tid _) = ThreadId (IOSim s)
ThreadId
tid

  cancel :: Async (IOSim s) a -> IOSim s ()
cancel a :: Async (IOSim s) a
a@(Async tid _) = ThreadId (IOSim s) -> AsyncCancelled -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
tid AsyncCancelled
AsyncCancelled IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async (IOSim s) a -> IOSim s (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async (IOSim s) a
a
  cancelWith :: Async (IOSim s) a -> e -> IOSim s ()
cancelWith a :: Async (IOSim s) a
a@(Async tid _) e
e = ThreadId (IOSim s) -> e -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
tid e
e IOSim s () -> IOSim s (Either SomeException a) -> IOSim s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Async (IOSim s) a -> IOSim s (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> m (Either SomeException a)
waitCatch Async (IOSim s) a
a

  asyncWithUnmask :: ((forall b. IOSim s b -> IOSim s b) -> IOSim s a)
-> IOSim s (Async (IOSim s) a)
asyncWithUnmask (forall b. IOSim s b -> IOSim s b) -> IOSim s a
k = IOSim s a -> IOSim s (Async (IOSim s) a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async ((forall b. IOSim s b -> IOSim s b) -> IOSim s a
k forall b. IOSim s b -> IOSim s b
forall s a. IOSim s a -> IOSim s a
unblock)

instance MonadST (IOSim s) where
  withLiftST :: (forall s. (forall a. ST s a -> IOSim s a) -> b) -> b
withLiftST forall s. (forall a. ST s a -> IOSim s a) -> b
f = (forall a. ST s a -> IOSim s a) -> b
forall s. (forall a. ST s a -> IOSim s a) -> b
f forall a. ST s a -> IOSim s a
forall s a. ST s a -> IOSim s a
liftST

liftST :: StrictST.ST s a -> IOSim s a
liftST :: ST s a -> IOSim s a
liftST ST s a
action = (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a)
-> (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \a -> SimA s r
k -> ST s a -> (a -> SimA s r) -> SimA s r
forall s a b. ST s a -> (a -> SimA s b) -> SimA s b
LiftST ST s a
action a -> SimA s r
k

instance MonadMonotonicTime (IOSim s) where
  getMonotonicTime :: IOSim s Time
getMonotonicTime = (forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time)
-> (forall r. (Time -> SimA s r) -> SimA s r) -> IOSim s Time
forall a b. (a -> b) -> a -> b
$ \Time -> SimA s r
k -> (Time -> SimA s r) -> SimA s r
forall s b. (Time -> SimA s b) -> SimA s b
GetMonoTime Time -> SimA s r
k

instance MonadTime (IOSim s) where
  getCurrentTime :: IOSim s UTCTime
getCurrentTime   = (forall r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime)
-> (forall r. (UTCTime -> SimA s r) -> SimA s r) -> IOSim s UTCTime
forall a b. (a -> b) -> a -> b
$ \UTCTime -> SimA s r
k -> (UTCTime -> SimA s r) -> SimA s r
forall s b. (UTCTime -> SimA s b) -> SimA s b
GetWallTime UTCTime -> SimA s r
k

-- | Set the current wall clock time for the thread's clock domain.
--
setCurrentTime :: UTCTime -> IOSim s ()
setCurrentTime :: UTCTime -> IOSim s ()
setCurrentTime UTCTime
t = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> UTCTime -> SimA s r -> SimA s r
forall s b. UTCTime -> SimA s b -> SimA s b
SetWallTime UTCTime
t (() -> SimA s r
k ())

-- | Put the thread into a new wall clock domain, not shared with the parent
-- thread. Changing the wall clock time in the new clock domain will not affect
-- the other clock of other threads. All threads forked by this thread from
-- this point onwards will share the new clock domain.
--
unshareClock :: IOSim s ()
unshareClock :: IOSim s ()
unshareClock = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> SimA s r -> SimA s r
forall s b. SimA s b -> SimA s b
UnshareClock (() -> SimA s r
k ())

instance MonadDelay (IOSim s) where
  -- Use default in terms of MonadTimer

instance MonadTimer (IOSim s) where
  data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !(TVar s Bool) !TimeoutId
                         -- ^ a timeout; we keep both 'TVar's to support
                         -- `newTimer` and 'registerTimeout'.
                         | NegativeTimeout !TimeoutId
                         -- ^ a negative timeout

  readTimeout :: Timeout (IOSim s) -> STM (IOSim s) TimeoutState
readTimeout (Timeout var _bvar _key) = TVar_ (STM s) TimeoutState -> STM s TimeoutState
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar_ (STM s) TimeoutState
TVar s TimeoutState
var
  readTimeout (NegativeTimeout _key)   = TimeoutState -> STM s TimeoutState
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeoutState
TimeoutCancelled

  newTimeout :: DiffTime -> IOSim s (Timeout (IOSim s))
newTimeout      DiffTime
d = (forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (Timeout (IOSim s))
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
 -> IOSim s (Timeout (IOSim s)))
-> (forall r. (Timeout (IOSim s) -> SimA s r) -> SimA s r)
-> IOSim s (Timeout (IOSim s))
forall a b. (a -> b) -> a -> b
$ \Timeout (IOSim s) -> SimA s r
k -> DiffTime -> (Timeout (IOSim s) -> SimA s r) -> SimA s r
forall s b. DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
NewTimeout      DiffTime
d Timeout (IOSim s) -> SimA s r
k
  updateTimeout :: Timeout (IOSim s) -> DiffTime -> IOSim s ()
updateTimeout Timeout (IOSim s)
t DiffTime
d = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> Timeout (IOSim s) -> DiffTime -> SimA s r -> SimA s r
forall s b. Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
UpdateTimeout Timeout (IOSim s)
t DiffTime
d (() -> SimA s r
k ())
  cancelTimeout :: Timeout (IOSim s) -> IOSim s ()
cancelTimeout Timeout (IOSim s)
t   = (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ())
-> (forall r. (() -> SimA s r) -> SimA s r) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ \() -> SimA s r
k -> Timeout (IOSim s) -> SimA s r -> SimA s r
forall s b. Timeout (IOSim s) -> SimA s b -> SimA s b
CancelTimeout Timeout (IOSim s)
t   (() -> SimA s r
k ())

  timeout :: DiffTime -> IOSim s a -> IOSim s (Maybe a)
timeout DiffTime
d IOSim s a
action
    | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<  DiffTime
0    = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IOSim s a -> IOSim s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action
    | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Eq a => a -> a -> Bool
== DiffTime
0    = Maybe a -> IOSim s (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = do
        ThreadId
pid <- IOSim s ThreadId
forall (m :: * -> *). MonadThread m => m (ThreadId m)
myThreadId
        t :: Timeout (IOSim s)
t@(Timeout _ _ tid) <- DiffTime -> IOSim s (Timeout (IOSim s))
forall (m :: * -> *). MonadTimer m => DiffTime -> m (Timeout m)
newTimeout DiffTime
d
        (TimeoutException -> Maybe ())
-> (() -> IOSim s (Maybe a))
-> IOSim s (Maybe a)
-> IOSim s (Maybe a)
forall (m :: * -> *) e b a.
(MonadCatch m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust
          (\(TimeoutException TimeoutId
tid') -> if TimeoutId
tid' TimeoutId -> TimeoutId -> Bool
forall a. Eq a => a -> a -> Bool
== TimeoutId
tid
                                         then () -> Maybe ()
forall a. a -> Maybe a
Just ()
                                         else Maybe ()
forall a. Maybe a
Nothing)
          (\()
_ -> Maybe a -> IOSim s (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) (IOSim s (Maybe a) -> IOSim s (Maybe a))
-> IOSim s (Maybe a) -> IOSim s (Maybe a)
forall a b. (a -> b) -> a -> b
$
          IOSim s ThreadId
-> (ThreadId -> IOSim s ())
-> (ThreadId -> IOSim s (Maybe a))
-> IOSim s (Maybe a)
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
            (IOSim s () -> IOSim s (ThreadId (IOSim s))
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (IOSim s () -> IOSim s (ThreadId (IOSim s)))
-> IOSim s () -> IOSim s (ThreadId (IOSim s))
forall a b. (a -> b) -> a -> b
$ do
                Bool
fired <- STM (IOSim s) Bool -> IOSim s Bool
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) Bool -> IOSim s Bool)
-> STM (IOSim s) Bool -> IOSim s Bool
forall a b. (a -> b) -> a -> b
$ Timeout (IOSim s) -> STM (IOSim s) Bool
forall (m :: * -> *). MonadTimer m => Timeout m -> STM m Bool
awaitTimeout Timeout (IOSim s)
t
                Bool -> IOSim s () -> IOSim s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fired (IOSim s () -> IOSim s ()) -> IOSim s () -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ ThreadId (IOSim s) -> TimeoutException -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
pid (TimeoutId -> TimeoutException
TimeoutException TimeoutId
tid))
            (\ThreadId
pid' -> do
                  Timeout (IOSim s) -> IOSim s ()
forall (m :: * -> *). MonadTimer m => Timeout m -> m ()
cancelTimeout Timeout (IOSim s)
t
                  ThreadId (IOSim s) -> AsyncCancelled -> IOSim s ()
forall (m :: * -> *) e.
(MonadFork m, Exception e) =>
ThreadId m -> e -> m ()
throwTo ThreadId (IOSim s)
ThreadId
pid' AsyncCancelled
AsyncCancelled)
            (\ThreadId
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IOSim s a -> IOSim s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOSim s a
action)

  registerDelay :: DiffTime -> IOSim s (TVar (IOSim s) Bool)
registerDelay DiffTime
d = (forall r. (TVar s Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar s Bool)
forall s a. (forall r. (a -> SimA s r) -> SimA s r) -> IOSim s a
IOSim ((forall r. (TVar s Bool -> SimA s r) -> SimA s r)
 -> IOSim s (TVar s Bool))
-> (forall r. (TVar s Bool -> SimA s r) -> SimA s r)
-> IOSim s (TVar s Bool)
forall a b. (a -> b) -> a -> b
$ \TVar s Bool -> SimA s r
k -> DiffTime -> (Timeout (IOSim s) -> SimA s r) -> SimA s r
forall s b. DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b
NewTimeout DiffTime
d (\(Timeout _var bvar _) -> TVar s Bool -> SimA s r
k TVar s Bool
bvar)

newtype TimeoutException = TimeoutException TimeoutId deriving TimeoutException -> TimeoutException -> Bool
(TimeoutException -> TimeoutException -> Bool)
-> (TimeoutException -> TimeoutException -> Bool)
-> Eq TimeoutException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c== :: TimeoutException -> TimeoutException -> Bool
Eq

instance Show TimeoutException where
    show :: TimeoutException -> String
show TimeoutException
_ = String
"<<timeout>>"

instance Exception TimeoutException where
  toException :: TimeoutException -> SomeException
toException   = TimeoutException -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe TimeoutException
fromException = SomeException -> Maybe TimeoutException
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

-- | Wrapper for Eventlog events so they can be retrieved from the trace with
-- 'selectTraceEventsDynamic'.
newtype EventlogEvent = EventlogEvent String

-- | Wrapper for Eventlog markers so they can be retrieved from the trace with
-- 'selectTraceEventsDynamic'.
newtype EventlogMarker = EventlogMarker String

instance MonadEventlog (IOSim s) where
  traceEventIO :: String -> IOSim s ()
traceEventIO = EventlogEvent -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (EventlogEvent -> IOSim s ())
-> (String -> EventlogEvent) -> String -> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EventlogEvent
EventlogEvent
  traceMarkerIO :: String -> IOSim s ()
traceMarkerIO = EventlogMarker -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (EventlogMarker -> IOSim s ())
-> (String -> EventlogMarker) -> String -> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EventlogMarker
EventlogMarker

--
-- Simulation interpreter
--

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

-- We hide the type @b@ here, so it's useful to bundle these two parts
-- together, rather than having Thread have an extential type, which
-- makes record updates awkward.
data ThreadControl s a where
  ThreadControl :: SimA s b
                -> ControlStack s b a
                -> ThreadControl s a

data ControlStack s b a where
  MainFrame  :: ControlStack s a  a
  ForkFrame  :: ControlStack s () a
  MaskFrame  :: (b -> SimA s c)         -- subsequent continuation
             -> MaskingState            -- thread local state to restore
             -> ControlStack s c a
             -> ControlStack s b a
  CatchFrame :: Exception e
             => (e -> SimA s b)         -- exception continuation
             -> (b -> SimA s c)         -- subsequent continuation
             -> ControlStack s c a
             -> ControlStack s b a

newtype ThreadId  = ThreadId  Int deriving (ThreadId -> ThreadId -> Bool
(ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool) -> Eq ThreadId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadId -> ThreadId -> Bool
$c/= :: ThreadId -> ThreadId -> Bool
== :: ThreadId -> ThreadId -> Bool
$c== :: ThreadId -> ThreadId -> Bool
Eq, Eq ThreadId
Eq ThreadId
-> (ThreadId -> ThreadId -> Ordering)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> Bool)
-> (ThreadId -> ThreadId -> ThreadId)
-> (ThreadId -> ThreadId -> ThreadId)
-> Ord ThreadId
ThreadId -> ThreadId -> Bool
ThreadId -> ThreadId -> Ordering
ThreadId -> ThreadId -> ThreadId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ThreadId -> ThreadId -> ThreadId
$cmin :: ThreadId -> ThreadId -> ThreadId
max :: ThreadId -> ThreadId -> ThreadId
$cmax :: ThreadId -> ThreadId -> ThreadId
>= :: ThreadId -> ThreadId -> Bool
$c>= :: ThreadId -> ThreadId -> Bool
> :: ThreadId -> ThreadId -> Bool
$c> :: ThreadId -> ThreadId -> Bool
<= :: ThreadId -> ThreadId -> Bool
$c<= :: ThreadId -> ThreadId -> Bool
< :: ThreadId -> ThreadId -> Bool
$c< :: ThreadId -> ThreadId -> Bool
compare :: ThreadId -> ThreadId -> Ordering
$ccompare :: ThreadId -> ThreadId -> Ordering
$cp1Ord :: Eq ThreadId
Ord, Int -> ThreadId
ThreadId -> Int
ThreadId -> [ThreadId]
ThreadId -> ThreadId
ThreadId -> ThreadId -> [ThreadId]
ThreadId -> ThreadId -> ThreadId -> [ThreadId]
(ThreadId -> ThreadId)
-> (ThreadId -> ThreadId)
-> (Int -> ThreadId)
-> (ThreadId -> Int)
-> (ThreadId -> [ThreadId])
-> (ThreadId -> ThreadId -> [ThreadId])
-> (ThreadId -> ThreadId -> [ThreadId])
-> (ThreadId -> ThreadId -> ThreadId -> [ThreadId])
-> Enum ThreadId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ThreadId -> ThreadId -> ThreadId -> [ThreadId]
$cenumFromThenTo :: ThreadId -> ThreadId -> ThreadId -> [ThreadId]
enumFromTo :: ThreadId -> ThreadId -> [ThreadId]
$cenumFromTo :: ThreadId -> ThreadId -> [ThreadId]
enumFromThen :: ThreadId -> ThreadId -> [ThreadId]
$cenumFromThen :: ThreadId -> ThreadId -> [ThreadId]
enumFrom :: ThreadId -> [ThreadId]
$cenumFrom :: ThreadId -> [ThreadId]
fromEnum :: ThreadId -> Int
$cfromEnum :: ThreadId -> Int
toEnum :: Int -> ThreadId
$ctoEnum :: Int -> ThreadId
pred :: ThreadId -> ThreadId
$cpred :: ThreadId -> ThreadId
succ :: ThreadId -> ThreadId
$csucc :: ThreadId -> ThreadId
Enum, Int -> ThreadId -> ShowS
[ThreadId] -> ShowS
ThreadId -> String
(Int -> ThreadId -> ShowS)
-> (ThreadId -> String) -> ([ThreadId] -> ShowS) -> Show ThreadId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadId] -> ShowS
$cshowList :: [ThreadId] -> ShowS
show :: ThreadId -> String
$cshow :: ThreadId -> String
showsPrec :: Int -> ThreadId -> ShowS
$cshowsPrec :: Int -> ThreadId -> ShowS
Show)
newtype TVarId    = TVarId    Int deriving (TVarId -> TVarId -> Bool
(TVarId -> TVarId -> Bool)
-> (TVarId -> TVarId -> Bool) -> Eq TVarId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TVarId -> TVarId -> Bool
$c/= :: TVarId -> TVarId -> Bool
== :: TVarId -> TVarId -> Bool
$c== :: TVarId -> TVarId -> Bool
Eq, Eq TVarId
Eq TVarId
-> (TVarId -> TVarId -> Ordering)
-> (TVarId -> TVarId -> Bool)
-> (TVarId -> TVarId -> Bool)
-> (TVarId -> TVarId -> Bool)
-> (TVarId -> TVarId -> Bool)
-> (TVarId -> TVarId -> TVarId)
-> (TVarId -> TVarId -> TVarId)
-> Ord TVarId
TVarId -> TVarId -> Bool
TVarId -> TVarId -> Ordering
TVarId -> TVarId -> TVarId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TVarId -> TVarId -> TVarId
$cmin :: TVarId -> TVarId -> TVarId
max :: TVarId -> TVarId -> TVarId
$cmax :: TVarId -> TVarId -> TVarId
>= :: TVarId -> TVarId -> Bool
$c>= :: TVarId -> TVarId -> Bool
> :: TVarId -> TVarId -> Bool
$c> :: TVarId -> TVarId -> Bool
<= :: TVarId -> TVarId -> Bool
$c<= :: TVarId -> TVarId -> Bool
< :: TVarId -> TVarId -> Bool
$c< :: TVarId -> TVarId -> Bool
compare :: TVarId -> TVarId -> Ordering
$ccompare :: TVarId -> TVarId -> Ordering
$cp1Ord :: Eq TVarId
Ord, Int -> TVarId
TVarId -> Int
TVarId -> [TVarId]
TVarId -> TVarId
TVarId -> TVarId -> [TVarId]
TVarId -> TVarId -> TVarId -> [TVarId]
(TVarId -> TVarId)
-> (TVarId -> TVarId)
-> (Int -> TVarId)
-> (TVarId -> Int)
-> (TVarId -> [TVarId])
-> (TVarId -> TVarId -> [TVarId])
-> (TVarId -> TVarId -> [TVarId])
-> (TVarId -> TVarId -> TVarId -> [TVarId])
-> Enum TVarId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TVarId -> TVarId -> TVarId -> [TVarId]
$cenumFromThenTo :: TVarId -> TVarId -> TVarId -> [TVarId]
enumFromTo :: TVarId -> TVarId -> [TVarId]
$cenumFromTo :: TVarId -> TVarId -> [TVarId]
enumFromThen :: TVarId -> TVarId -> [TVarId]
$cenumFromThen :: TVarId -> TVarId -> [TVarId]
enumFrom :: TVarId -> [TVarId]
$cenumFrom :: TVarId -> [TVarId]
fromEnum :: TVarId -> Int
$cfromEnum :: TVarId -> Int
toEnum :: Int -> TVarId
$ctoEnum :: Int -> TVarId
pred :: TVarId -> TVarId
$cpred :: TVarId -> TVarId
succ :: TVarId -> TVarId
$csucc :: TVarId -> TVarId
Enum, Int -> TVarId -> ShowS
[TVarId] -> ShowS
TVarId -> String
(Int -> TVarId -> ShowS)
-> (TVarId -> String) -> ([TVarId] -> ShowS) -> Show TVarId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TVarId] -> ShowS
$cshowList :: [TVarId] -> ShowS
show :: TVarId -> String
$cshow :: TVarId -> String
showsPrec :: Int -> TVarId -> ShowS
$cshowsPrec :: Int -> TVarId -> ShowS
Show)
newtype TimeoutId = TimeoutId Int deriving (TimeoutId -> TimeoutId -> Bool
(TimeoutId -> TimeoutId -> Bool)
-> (TimeoutId -> TimeoutId -> Bool) -> Eq TimeoutId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeoutId -> TimeoutId -> Bool
$c/= :: TimeoutId -> TimeoutId -> Bool
== :: TimeoutId -> TimeoutId -> Bool
$c== :: TimeoutId -> TimeoutId -> Bool
Eq, Eq TimeoutId
Eq TimeoutId
-> (TimeoutId -> TimeoutId -> Ordering)
-> (TimeoutId -> TimeoutId -> Bool)
-> (TimeoutId -> TimeoutId -> Bool)
-> (TimeoutId -> TimeoutId -> Bool)
-> (TimeoutId -> TimeoutId -> Bool)
-> (TimeoutId -> TimeoutId -> TimeoutId)
-> (TimeoutId -> TimeoutId -> TimeoutId)
-> Ord TimeoutId
TimeoutId -> TimeoutId -> Bool
TimeoutId -> TimeoutId -> Ordering
TimeoutId -> TimeoutId -> TimeoutId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimeoutId -> TimeoutId -> TimeoutId
$cmin :: TimeoutId -> TimeoutId -> TimeoutId
max :: TimeoutId -> TimeoutId -> TimeoutId
$cmax :: TimeoutId -> TimeoutId -> TimeoutId
>= :: TimeoutId -> TimeoutId -> Bool
$c>= :: TimeoutId -> TimeoutId -> Bool
> :: TimeoutId -> TimeoutId -> Bool
$c> :: TimeoutId -> TimeoutId -> Bool
<= :: TimeoutId -> TimeoutId -> Bool
$c<= :: TimeoutId -> TimeoutId -> Bool
< :: TimeoutId -> TimeoutId -> Bool
$c< :: TimeoutId -> TimeoutId -> Bool
compare :: TimeoutId -> TimeoutId -> Ordering
$ccompare :: TimeoutId -> TimeoutId -> Ordering
$cp1Ord :: Eq TimeoutId
Ord, Int -> TimeoutId
TimeoutId -> Int
TimeoutId -> [TimeoutId]
TimeoutId -> TimeoutId
TimeoutId -> TimeoutId -> [TimeoutId]
TimeoutId -> TimeoutId -> TimeoutId -> [TimeoutId]
(TimeoutId -> TimeoutId)
-> (TimeoutId -> TimeoutId)
-> (Int -> TimeoutId)
-> (TimeoutId -> Int)
-> (TimeoutId -> [TimeoutId])
-> (TimeoutId -> TimeoutId -> [TimeoutId])
-> (TimeoutId -> TimeoutId -> [TimeoutId])
-> (TimeoutId -> TimeoutId -> TimeoutId -> [TimeoutId])
-> Enum TimeoutId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TimeoutId -> TimeoutId -> TimeoutId -> [TimeoutId]
$cenumFromThenTo :: TimeoutId -> TimeoutId -> TimeoutId -> [TimeoutId]
enumFromTo :: TimeoutId -> TimeoutId -> [TimeoutId]
$cenumFromTo :: TimeoutId -> TimeoutId -> [TimeoutId]
enumFromThen :: TimeoutId -> TimeoutId -> [TimeoutId]
$cenumFromThen :: TimeoutId -> TimeoutId -> [TimeoutId]
enumFrom :: TimeoutId -> [TimeoutId]
$cenumFrom :: TimeoutId -> [TimeoutId]
fromEnum :: TimeoutId -> Int
$cfromEnum :: TimeoutId -> Int
toEnum :: Int -> TimeoutId
$ctoEnum :: Int -> TimeoutId
pred :: TimeoutId -> TimeoutId
$cpred :: TimeoutId -> TimeoutId
succ :: TimeoutId -> TimeoutId
$csucc :: TimeoutId -> TimeoutId
Enum, Int -> TimeoutId -> ShowS
[TimeoutId] -> ShowS
TimeoutId -> String
(Int -> TimeoutId -> ShowS)
-> (TimeoutId -> String)
-> ([TimeoutId] -> ShowS)
-> Show TimeoutId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutId] -> ShowS
$cshowList :: [TimeoutId] -> ShowS
show :: TimeoutId -> String
$cshow :: TimeoutId -> String
showsPrec :: Int -> TimeoutId -> ShowS
$cshowsPrec :: Int -> TimeoutId -> ShowS
Show)
newtype ClockId   = ClockId   Int deriving (ClockId -> ClockId -> Bool
(ClockId -> ClockId -> Bool)
-> (ClockId -> ClockId -> Bool) -> Eq ClockId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClockId -> ClockId -> Bool
$c/= :: ClockId -> ClockId -> Bool
== :: ClockId -> ClockId -> Bool
$c== :: ClockId -> ClockId -> Bool
Eq, Eq ClockId
Eq ClockId
-> (ClockId -> ClockId -> Ordering)
-> (ClockId -> ClockId -> Bool)
-> (ClockId -> ClockId -> Bool)
-> (ClockId -> ClockId -> Bool)
-> (ClockId -> ClockId -> Bool)
-> (ClockId -> ClockId -> ClockId)
-> (ClockId -> ClockId -> ClockId)
-> Ord ClockId
ClockId -> ClockId -> Bool
ClockId -> ClockId -> Ordering
ClockId -> ClockId -> ClockId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ClockId -> ClockId -> ClockId
$cmin :: ClockId -> ClockId -> ClockId
max :: ClockId -> ClockId -> ClockId
$cmax :: ClockId -> ClockId -> ClockId
>= :: ClockId -> ClockId -> Bool
$c>= :: ClockId -> ClockId -> Bool
> :: ClockId -> ClockId -> Bool
$c> :: ClockId -> ClockId -> Bool
<= :: ClockId -> ClockId -> Bool
$c<= :: ClockId -> ClockId -> Bool
< :: ClockId -> ClockId -> Bool
$c< :: ClockId -> ClockId -> Bool
compare :: ClockId -> ClockId -> Ordering
$ccompare :: ClockId -> ClockId -> Ordering
$cp1Ord :: Eq ClockId
Ord, Int -> ClockId
ClockId -> Int
ClockId -> [ClockId]
ClockId -> ClockId
ClockId -> ClockId -> [ClockId]
ClockId -> ClockId -> ClockId -> [ClockId]
(ClockId -> ClockId)
-> (ClockId -> ClockId)
-> (Int -> ClockId)
-> (ClockId -> Int)
-> (ClockId -> [ClockId])
-> (ClockId -> ClockId -> [ClockId])
-> (ClockId -> ClockId -> [ClockId])
-> (ClockId -> ClockId -> ClockId -> [ClockId])
-> Enum ClockId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ClockId -> ClockId -> ClockId -> [ClockId]
$cenumFromThenTo :: ClockId -> ClockId -> ClockId -> [ClockId]
enumFromTo :: ClockId -> ClockId -> [ClockId]
$cenumFromTo :: ClockId -> ClockId -> [ClockId]
enumFromThen :: ClockId -> ClockId -> [ClockId]
$cenumFromThen :: ClockId -> ClockId -> [ClockId]
enumFrom :: ClockId -> [ClockId]
$cenumFrom :: ClockId -> [ClockId]
fromEnum :: ClockId -> Int
$cfromEnum :: ClockId -> Int
toEnum :: Int -> ClockId
$ctoEnum :: Int -> ClockId
pred :: ClockId -> ClockId
$cpred :: ClockId -> ClockId
succ :: ClockId -> ClockId
$csucc :: ClockId -> ClockId
Enum, Int -> ClockId -> ShowS
[ClockId] -> ShowS
ClockId -> String
(Int -> ClockId -> ShowS)
-> (ClockId -> String) -> ([ClockId] -> ShowS) -> Show ClockId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClockId] -> ShowS
$cshowList :: [ClockId] -> ShowS
show :: ClockId -> String
$cshow :: ClockId -> String
showsPrec :: Int -> ClockId -> ShowS
$cshowsPrec :: Int -> ClockId -> ShowS
Show)

type ThreadLabel = String

data LabeledThread = LabeledThread {
    LabeledThread -> ThreadId
labeledThreadId    :: ThreadId,
    LabeledThread -> Maybe String
labeledThreadLabel :: Maybe ThreadLabel
  }
  deriving (LabeledThread -> LabeledThread -> Bool
(LabeledThread -> LabeledThread -> Bool)
-> (LabeledThread -> LabeledThread -> Bool) -> Eq LabeledThread
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LabeledThread -> LabeledThread -> Bool
$c/= :: LabeledThread -> LabeledThread -> Bool
== :: LabeledThread -> LabeledThread -> Bool
$c== :: LabeledThread -> LabeledThread -> Bool
Eq, Eq LabeledThread
Eq LabeledThread
-> (LabeledThread -> LabeledThread -> Ordering)
-> (LabeledThread -> LabeledThread -> Bool)
-> (LabeledThread -> LabeledThread -> Bool)
-> (LabeledThread -> LabeledThread -> Bool)
-> (LabeledThread -> LabeledThread -> Bool)
-> (LabeledThread -> LabeledThread -> LabeledThread)
-> (LabeledThread -> LabeledThread -> LabeledThread)
-> Ord LabeledThread
LabeledThread -> LabeledThread -> Bool
LabeledThread -> LabeledThread -> Ordering
LabeledThread -> LabeledThread -> LabeledThread
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LabeledThread -> LabeledThread -> LabeledThread
$cmin :: LabeledThread -> LabeledThread -> LabeledThread
max :: LabeledThread -> LabeledThread -> LabeledThread
$cmax :: LabeledThread -> LabeledThread -> LabeledThread
>= :: LabeledThread -> LabeledThread -> Bool
$c>= :: LabeledThread -> LabeledThread -> Bool
> :: LabeledThread -> LabeledThread -> Bool
$c> :: LabeledThread -> LabeledThread -> Bool
<= :: LabeledThread -> LabeledThread -> Bool
$c<= :: LabeledThread -> LabeledThread -> Bool
< :: LabeledThread -> LabeledThread -> Bool
$c< :: LabeledThread -> LabeledThread -> Bool
compare :: LabeledThread -> LabeledThread -> Ordering
$ccompare :: LabeledThread -> LabeledThread -> Ordering
$cp1Ord :: Eq LabeledThread
Ord, Int -> LabeledThread -> ShowS
[LabeledThread] -> ShowS
LabeledThread -> String
(Int -> LabeledThread -> ShowS)
-> (LabeledThread -> String)
-> ([LabeledThread] -> ShowS)
-> Show LabeledThread
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LabeledThread] -> ShowS
$cshowList :: [LabeledThread] -> ShowS
show :: LabeledThread -> String
$cshow :: LabeledThread -> String
showsPrec :: Int -> LabeledThread -> ShowS
$cshowsPrec :: Int -> LabeledThread -> ShowS
Show)

labeledThreads :: Map ThreadId (Thread s a) -> [LabeledThread]
labeledThreads :: Map ThreadId (Thread s a) -> [LabeledThread]
labeledThreads 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
    (Thread s a -> [LabeledThread] -> [LabeledThread])
-> [LabeledThread] -> Map ThreadId (Thread s a) -> [LabeledThread]
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 String
threadLabel :: Maybe String
threadLabel :: forall s a. Thread s a -> Maybe String
threadLabel } ![LabeledThread]
acc -> ThreadId -> Maybe String -> LabeledThread
LabeledThread ThreadId
threadId Maybe String
threadLabel LabeledThread -> [LabeledThread] -> [LabeledThread]
forall a. a -> [a] -> [a]
: [LabeledThread]
acc)
      [] Map ThreadId (Thread s a)
threadMap


-- | 'Trace' is a recursive data type, it is the trace of a 'IOSim' computation.
-- The trace will contain information about thread sheduling, blocking on
-- 'TVar's, and other internal state changes of 'IOSim'.  More importantly it
-- also supports traces generated by the computation with 'say' (which
-- corresponds to using 'putStrLn' in 'IO'), 'traceEventM', or dynamically typed
-- traces with 'traceM' (which generalise the @base@ library
-- 'Debug.Trace.traceM')
--
-- See also: 'traceEvents', 'traceResult', 'selectTraceEvents',
-- 'selectTraceEventsDynamic' and 'printTraceEventsSay'.
--
data Trace a = Trace !Time !ThreadId !(Maybe ThreadLabel) !TraceEvent (Trace a)
             | TraceMainReturn    !Time a             ![LabeledThread]
             | TraceMainException !Time SomeException ![LabeledThread]
             | TraceDeadlock      !Time               ![LabeledThread]
  deriving Int -> Trace a -> ShowS
[Trace a] -> ShowS
Trace a -> String
(Int -> Trace a -> ShowS)
-> (Trace a -> String) -> ([Trace a] -> ShowS) -> Show (Trace a)
forall a. Show a => Int -> Trace a -> ShowS
forall a. Show a => [Trace a] -> ShowS
forall a. Show a => Trace a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trace a] -> ShowS
$cshowList :: forall a. Show a => [Trace a] -> ShowS
show :: Trace a -> String
$cshow :: forall a. Show a => Trace a -> String
showsPrec :: Int -> Trace a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Trace a -> ShowS
Show

data TraceEvent
  = EventSay  String
  | EventLog  Dynamic

  | EventThrow          SomeException
  | EventThrowTo        SomeException ThreadId -- This thread used ThrowTo
  | EventThrowToBlocked                        -- The ThrowTo blocked
  | EventThrowToWakeup                         -- The ThrowTo resumed
  | EventThrowToUnmasked ThreadId              -- A pending ThrowTo was activated

  | EventThreadForked    ThreadId
  | EventThreadFinished                  -- terminated normally
  | EventThreadUnhandled SomeException   -- terminated due to unhandled exception

  | EventTxCommitted   [TVarId] -- tx wrote to these
                       [TVarId] -- and created these
  | EventTxAborted
  | EventTxBlocked     [TVarId] -- tx blocked reading these
  | EventTxWakeup      [TVarId] -- changed vars causing retry

  | EventTimerCreated   TimeoutId TVarId Time
  | EventTimerUpdated   TimeoutId        Time
  | EventTimerCancelled TimeoutId
  | EventTimerExpired   TimeoutId
  deriving Int -> TraceEvent -> ShowS
[TraceEvent] -> ShowS
TraceEvent -> String
(Int -> TraceEvent -> ShowS)
-> (TraceEvent -> String)
-> ([TraceEvent] -> ShowS)
-> Show TraceEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceEvent] -> ShowS
$cshowList :: [TraceEvent] -> ShowS
show :: TraceEvent -> String
$cshow :: TraceEvent -> String
showsPrec :: Int -> TraceEvent -> ShowS
$cshowsPrec :: Int -> TraceEvent -> ShowS
Show


-- | Timers mutable variables.  First one supports 'newTimeout' api, the second
-- one 'registerDelay'.
--
data TimerVars s = TimerVars !(TVar s TimeoutState) !(TVar s Bool)


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

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

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

invariant :: Maybe (Thread s a) -> SimState s a -> Bool
invariant (Just Thread s a
running) simstate :: SimState s a
simstate@SimState{[ThreadId]
runqueue :: [ThreadId]
runqueue :: forall s a. SimState s a -> [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} =
    Bool -> Bool
not (Thread s a -> Bool
forall s a. Thread s a -> Bool
threadBlocked Thread s a
running)
 Bool -> Bool -> Bool
&& Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
running ThreadId -> Map ThreadId (Thread s a) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map ThreadId (Thread s a)
threads
 Bool -> Bool -> Bool
&& Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
running ThreadId -> [ThreadId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.notElem` [ThreadId]
runqueue
 Bool -> Bool -> Bool
&& Thread s a -> ClockId
forall s a. Thread s a -> ClockId
threadClockId Thread s a
running ClockId -> Map ClockId UTCTime -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ClockId UTCTime
clocks
 Bool -> Bool -> Bool
&& Maybe (Thread s a) -> SimState s a -> Bool
forall s a. Maybe (Thread s a) -> SimState s a -> Bool
invariant Maybe (Thread s a)
forall a. Maybe a
Nothing SimState s a
simstate

invariant Maybe (Thread s a)
Nothing SimState{[ThreadId]
runqueue :: [ThreadId]
runqueue :: forall s a. SimState s a -> [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} =
    (ThreadId -> Bool) -> [ThreadId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ThreadId -> Map ThreadId (Thread s a) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ThreadId (Thread s a)
threads) [ThreadId]
runqueue
 Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Thread s a -> Bool
forall s a. Thread s a -> Bool
threadBlocked Thread s a
t Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
t ThreadId -> [ThreadId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ThreadId]
runqueue)
        | Thread s a
t <- Map ThreadId (Thread s a) -> [Thread s a]
forall k a. Map k a -> [a]
Map.elems Map ThreadId (Thread s a)
threads ]
 Bool -> Bool -> Bool
&& [ThreadId]
runqueue [ThreadId] -> [ThreadId] -> Bool
forall a. Eq a => a -> a -> Bool
== [ThreadId] -> [ThreadId]
forall a. Eq a => [a] -> [a]
List.nub [ThreadId]
runqueue
 Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Thread s a -> ClockId
forall s a. Thread s a -> ClockId
threadClockId Thread s a
t ClockId -> Map ClockId UTCTime -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map ClockId UTCTime
clocks
        | Thread s a
t <- Map ThreadId (Thread s a) -> [Thread s a]
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.
timeSiceEpoch :: Time -> NominalDiffTime
timeSiceEpoch :: Time -> NominalDiffTime
timeSiceEpoch (Time DiffTime
t) = Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (DiffTime -> Rational
forall a. Real a => a -> Rational
toRational DiffTime
t)


-- | Schedule / run a thread.
--
schedule :: Thread s a -> SimState s a -> ST s (Trace a)
schedule :: Thread s a -> SimState s a -> ST s (Trace 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 String
threadLabel   = Maybe String
tlbl
         }
         simstate :: SimState s a
simstate@SimState {
           [ThreadId]
runqueue :: [ThreadId]
runqueue :: forall s a. SimState s a -> [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,
           OrdPSQ TimeoutId Time (TimerVars s)
timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers :: forall s a. SimState s a -> OrdPSQ TimeoutId Time (TimerVars s)
timers,
           Map ClockId UTCTime
clocks :: Map ClockId UTCTime
clocks :: forall s a. SimState s a -> Map ClockId UTCTime
clocks,
           ThreadId
nextTid :: ThreadId
nextTid :: forall s a. SimState s a -> ThreadId
nextTid, 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
         } =
  Bool -> ST s (Trace a) -> ST s (Trace a)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Thread s a) -> SimState s a -> Bool
forall s a. Maybe (Thread s a) -> SimState s a -> Bool
invariant (Thread s a -> Maybe (Thread s a)
forall a. a -> Maybe a
Just Thread s a
thread) SimState s a
simstate) (ST s (Trace a) -> ST s (Trace a))
-> ST s (Trace a) -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$
  case SimA s b
action of

    Return b
x -> 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
        Trace b -> ST s (Trace b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace b -> ST s (Trace b)) -> Trace b -> ST s (Trace b)
forall a b. (a -> b) -> a -> b
$ Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace b -> Trace b
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl TraceEvent
EventThreadFinished
               (Trace b -> Trace b) -> Trace b -> Trace b
forall a b. (a -> b) -> a -> b
$ Time -> b -> [LabeledThread] -> Trace b
forall a. Time -> a -> [LabeledThread] -> Trace a
TraceMainReturn Time
time b
x (Map ThreadId (Thread s a) -> [LabeledThread]
forall s a. Map ThreadId (Thread s a) -> [LabeledThread]
labeledThreads Map ThreadId (Thread s a)
threads)

      ControlStack s b a
ForkFrame -> do
        -- this thread is done
        Trace a
trace <- Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Terminated Thread s a
thread SimState s a
simstate
        Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$ Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl TraceEvent
EventThreadFinished Trace 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 = SimA s c -> ControlStack s c a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b 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
        Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Interruptable Thread s a
thread' SimState s a
simstate

      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 = SimA s c -> ControlStack s c a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (b -> SimA s c
k b
x) ControlStack s c a
ctl' }
        Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

    Throw SomeException
e -> case SomeException -> Thread s a -> Either Bool (Thread s a)
forall s a. SomeException -> Thread s a -> Either Bool (Thread s a)
unwindControlStack SomeException
e Thread s a
thread of
      Right Thread s a
thread' -> do
        -- We found a suitable exception handler, continue with that
        Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate
        Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> TraceEvent
EventThrow SomeException
e) Trace a
trace)

      Left Bool
isMain
        -- 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
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> TraceEvent
EventThrow SomeException
e) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
                  Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> TraceEvent
EventThreadUnhandled SomeException
e) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
                  Time -> SomeException -> [LabeledThread] -> Trace a
forall a. Time -> SomeException -> [LabeledThread] -> Trace a
TraceMainException Time
time SomeException
e (Map ThreadId (Thread s a) -> [LabeledThread]
forall s a. Map ThreadId (Thread s a) -> [LabeledThread]
labeledThreads Map ThreadId (Thread s a)
threads))

        | Bool
otherwise -> do
          -- An unhandled exception in any other thread terminates the thread
          Trace a
trace <- Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Terminated Thread s a
thread SimState s a
simstate
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> TraceEvent
EventThrow SomeException
e) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
                  Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> TraceEvent
EventThreadUnhandled SomeException
e) Trace a
trace)

    Catch SimA s a
action' e -> SimA s a
handler a -> SimA s b
k -> 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 = SimA s a -> ControlStack s a a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s a
action'
                                               ((e -> SimA s a)
-> (a -> SimA s b) -> ControlStack s b a -> ControlStack s a a
forall e s b c a.
Exception e =>
(e -> 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) }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

    Evaluate a
expr a -> SimA s b
k -> do
      Either SomeException a
mbWHNF <- IO (Either SomeException a) -> ST s (Either SomeException a)
forall a s. IO a -> ST s a
unsafeIOToST (IO (Either SomeException a) -> ST s (Either SomeException a))
-> IO (Either SomeException a) -> ST s (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ a -> IO a
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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (SomeException -> SimA s b
forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl }
          Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
whnf) ControlStack s b a
ctl }
          Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

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

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

    LiftST ST s a
st a -> SimA s b
k -> do
      a
x <- ST s a -> ST s a
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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

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

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

    SetWallTime UTCTime
walltime' SimA s b
k -> do
      let clockid :: ClockId
clockid   = Thread s a -> ClockId
forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
          clockoff :: UTCTime
clockoff  = Map ClockId UTCTime
clocks Map ClockId UTCTime -> ClockId -> UTCTime
forall k a. Ord k => Map k a -> k -> a
Map.! ClockId
clockid
          walltime :: UTCTime
walltime  = Time -> NominalDiffTime
timeSiceEpoch 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b 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 = ClockId -> UTCTime -> Map ClockId UTCTime -> Map ClockId UTCTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ClockId
clockid UTCTime
clockoff' Map ClockId UTCTime
clocks }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate'

    UnshareClock SimA s b
k -> do
      let clockid :: ClockId
clockid   = Thread s a -> ClockId
forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
          clockoff :: UTCTime
clockoff  = Map ClockId UTCTime
clocks Map ClockId UTCTime -> ClockId -> UTCTime
forall k a. Ord k => Map k a -> k -> a
Map.! ClockId
clockid
          clockid' :: ClockId
clockid'  = (Int -> ClockId
forall a. Enum a => Int -> a
toEnum (Int -> ClockId) -> (ThreadId -> Int) -> ThreadId -> ClockId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Int
forall a. Enum a => a -> Int
fromEnum) ThreadId
tid -- reuse the thread id
          thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b 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 = ClockId -> UTCTime -> Map ClockId UTCTime -> Map ClockId UTCTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ClockId
clockid' UTCTime
clockoff Map ClockId UTCTime
clocks }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate'

    -- 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 (IOSim s) -> SimA s b
k | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0 -> do
      let t :: Timeout (IOSim s)
t       = TimeoutId -> Timeout (IOSim s)
forall s. TimeoutId -> Timeout (IOSim 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (Timeout (IOSim s) -> SimA s b
k Timeout (IOSim s)
t) ControlStack s b a
ctl }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { nextTmid :: TimeoutId
nextTmid = TimeoutId -> TimeoutId
forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> TVarId -> Time -> TraceEvent
EventTimerCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
              Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> TraceEvent
EventTimerCancelled TimeoutId
nextTmid) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
              Trace a
trace)

    NewTimeout DiffTime
d Timeout (IOSim s) -> SimA s b
k -> do
      TVar s TimeoutState
tvar  <- TVarId -> TimeoutState -> ST s (TVar s TimeoutState)
forall a s. TVarId -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid TimeoutState
TimeoutPending
      TVar s Bool
tvar' <- TVarId -> Bool -> ST s (TVar s Bool)
forall a s. TVarId -> a -> ST s (TVar s a)
execNewTVar (TVarId -> TVarId
forall a. Enum a => a -> a
succ TVarId
nextVid) Bool
False
      let expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          t :: Timeout (IOSim s)
t       = TVar s TimeoutState
-> TVar s Bool -> TimeoutId -> Timeout (IOSim s)
forall s.
TVar s TimeoutState
-> TVar s Bool -> TimeoutId -> Timeout (IOSim s)
Timeout TVar s TimeoutState
tvar TVar s Bool
tvar' TimeoutId
nextTmid
          timers' :: OrdPSQ TimeoutId Time (TimerVars s)
timers' = TimeoutId
-> Time
-> TimerVars s
-> OrdPSQ TimeoutId Time (TimerVars s)
-> OrdPSQ TimeoutId Time (TimerVars s)
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 (TVar s TimeoutState -> TVar s Bool -> TimerVars s
forall s. TVar s TimeoutState -> TVar s Bool -> TimerVars s
TimerVars TVar s TimeoutState
tvar TVar s Bool
tvar') OrdPSQ TimeoutId Time (TimerVars s)
timers
          thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (Timeout (IOSim s) -> SimA s b
k Timeout (IOSim s)
t) ControlStack s b a
ctl }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers   = OrdPSQ TimeoutId Time (TimerVars s)
timers'
                                         , nextVid :: TVarId
nextVid  = TVarId -> TVarId
forall a. Enum a => a -> a
succ (TVarId -> TVarId
forall a. Enum a => a -> a
succ TVarId
nextVid)
                                         , nextTmid :: TimeoutId
nextTmid = TimeoutId -> TimeoutId
forall a. Enum a => a -> a
succ TimeoutId
nextTmid }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> TVarId -> Time -> TraceEvent
EventTimerCreated TimeoutId
nextTmid TVarId
nextVid Time
expiry) Trace a
trace)

    -- we do not follow `GHC.Event` behaviour here; updating a timer to the past
    -- effectively cancels it.
    UpdateTimeout (Timeout _tvar _tvar' tmid) DiffTime
d SimA s b
k | DiffTime
d DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0 -> do
      let timers' :: OrdPSQ TimeoutId Time (TimerVars s)
timers' = TimeoutId
-> OrdPSQ TimeoutId Time (TimerVars s)
-> OrdPSQ TimeoutId Time (TimerVars s)
forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid OrdPSQ TimeoutId Time (TimerVars s)
timers
          thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers = OrdPSQ TimeoutId Time (TimerVars s)
timers' }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> TraceEvent
EventTimerCancelled TimeoutId
tmid) Trace a
trace)

    UpdateTimeout (Timeout _tvar _tvar' tmid) DiffTime
d SimA s b
k -> do
          -- updating an expired timeout is a noop, so it is safe
          -- to race using a timeout with updating or cancelling it
      let updateTimeout_ :: Maybe (Time, TimerVars s) -> ((), Maybe (Time, TimerVars s))
updateTimeout_  Maybe (Time, TimerVars s)
Nothing       = ((), Maybe (Time, TimerVars s)
forall a. Maybe a
Nothing)
          updateTimeout_ (Just (Time
_p, TimerVars s
v)) = ((), (Time, TimerVars s) -> Maybe (Time, TimerVars s)
forall a. a -> Maybe a
Just (Time
expiry, TimerVars s
v))
          expiry :: Time
expiry  = DiffTime
d DiffTime -> Time -> Time
`addTime` Time
time
          timers' :: OrdPSQ TimeoutId Time (TimerVars s)
timers' = ((), OrdPSQ TimeoutId Time (TimerVars s))
-> OrdPSQ TimeoutId Time (TimerVars s)
forall a b. (a, b) -> b
snd ((Maybe (Time, TimerVars s) -> ((), Maybe (Time, TimerVars s)))
-> TimeoutId
-> OrdPSQ TimeoutId Time (TimerVars s)
-> ((), OrdPSQ TimeoutId Time (TimerVars s))
forall k p v b.
(Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> OrdPSQ k p v -> (b, OrdPSQ k p v)
PSQ.alter Maybe (Time, TimerVars s) -> ((), Maybe (Time, TimerVars s))
updateTimeout_ TimeoutId
tmid OrdPSQ TimeoutId Time (TimerVars s)
timers)
          thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers = OrdPSQ TimeoutId Time (TimerVars s)
timers' }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> Time -> TraceEvent
EventTimerUpdated TimeoutId
tmid Time
expiry) Trace a
trace)

    -- updating a negative timer is a no-op, unlike in `GHC.Event`.
    UpdateTimeout (NegativeTimeout _tmid) DiffTime
_d SimA s b
k -> do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

    CancelTimeout (Timeout _tvar _tvar' tmid) SimA s b
k -> do
      let timers' :: OrdPSQ TimeoutId Time (TimerVars s)
timers' = TimeoutId
-> OrdPSQ TimeoutId Time (TimerVars s)
-> OrdPSQ TimeoutId Time (TimerVars s)
forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete TimeoutId
tmid OrdPSQ TimeoutId Time (TimerVars s)
timers
          thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers = OrdPSQ TimeoutId Time (TimerVars s)
timers' }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (TimeoutId -> TraceEvent
EventTimerCancelled TimeoutId
tmid) Trace a
trace)

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

    Fork IOSim s ()
a ThreadId -> SimA s b
k -> do
      let tid' :: ThreadId
tid'     = ThreadId
nextTid
          thread' :: Thread s a
thread'  = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (ThreadId -> SimA s b
k ThreadId
tid') ControlStack s b a
ctl }
          thread'' :: Thread s a
thread'' = Thread :: forall s a.
ThreadId
-> ThreadControl s a
-> Bool
-> MaskingState
-> [(SomeException, ThreadId)]
-> ClockId
-> Maybe String
-> Thread s a
Thread { threadId :: ThreadId
threadId      = ThreadId
tid'
                            , threadControl :: ThreadControl s a
threadControl = SimA s () -> ControlStack s () a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (IOSim s () -> SimA s ()
forall s a. IOSim s a -> SimA s a
runIOSim IOSim s ()
a)
                                                            ControlStack s () a
forall s a. ControlStack s () a
ForkFrame
                            , threadBlocked :: Bool
threadBlocked = Bool
False
                            , threadMasking :: MaskingState
threadMasking = Thread s a -> MaskingState
forall s a. Thread s a -> MaskingState
threadMasking Thread s a
thread
                            , threadThrowTo :: [(SomeException, ThreadId)]
threadThrowTo = []
                            , threadClockId :: ClockId
threadClockId = Thread s a -> ClockId
forall s a. Thread s a -> ClockId
threadClockId Thread s a
thread
                            , threadLabel :: Maybe String
threadLabel   = Maybe String
forall a. Maybe a
Nothing
                            }
          threads' :: Map ThreadId (Thread s a)
threads' = ThreadId
-> Thread s a
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
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
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate { runqueue :: [ThreadId]
runqueue = [ThreadId]
runqueue [ThreadId] -> [ThreadId] -> [ThreadId]
forall a. [a] -> [a] -> [a]
++ [ThreadId
tid']
                                         , threads :: Map ThreadId (Thread s a)
threads  = Map ThreadId (Thread s a)
threads'
                                         , nextTid :: ThreadId
nextTid  = ThreadId -> ThreadId
forall a. Enum a => a -> a
succ ThreadId
nextTid }
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (ThreadId -> TraceEvent
EventThreadForked ThreadId
tid') Trace a
trace)

    Atomically STM s a
a a -> SimA s b
k -> do
      StmTxResult s a
res <- TVarId -> StmA s a -> ST s (StmTxResult s a)
forall s a. TVarId -> StmA s a -> ST s (StmTxResult s a)
execAtomically TVarId
nextVid (STM s a -> StmA s a
forall s a. STM s a -> StmA s a
runSTM STM s a
a)
      case StmTxResult s a
res of
        StmTxCommitted a
x [SomeTVar s]
written TVarId
nextVid' -> do
          ([ThreadId]
wakeup, Map ThreadId (Set TVarId)
wokeby) <- [SomeTVar s] -> ST s ([ThreadId], Map ThreadId (Set TVarId))
forall s.
[SomeTVar s] -> ST s ([ThreadId], Map ThreadId (Set TVarId))
threadsUnblockedByWrites [SomeTVar s]
written
          (SomeTVar s -> ST s ()) -> [SomeTVar s] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
              ([ThreadId]
unblocked,
               SimState s a
simstate') = [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
forall s a.
[ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId]
wakeup SimState s a
simstate
              vids :: [TVarId]
vids        = [ TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar | SomeTVar TVar s a
tvar <- [SomeTVar s]
written ]
              -- 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).
          Trace a
trace <- Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Yield Thread s a
thread' SimState s a
simstate' { nextVid :: TVarId
nextVid  = TVarId
nextVid' }
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$
            Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl ([TVarId] -> [TVarId] -> TraceEvent
EventTxCommitted [TVarId]
vids [TVarId
nextVid..TVarId -> TVarId
forall a. Enum a => a -> a
pred TVarId
nextVid']) (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$
            [(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
forall a.
[(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
traceMany
              [ (Time
time, ThreadId
tid', Maybe String
tlbl', [TVarId] -> TraceEvent
EventTxWakeup [TVarId]
vids')
              | ThreadId
tid' <- [ThreadId]
unblocked
              , let tlbl' :: Maybe String
tlbl' = ThreadId -> Map ThreadId (Thread s a) -> Maybe String
forall s a. ThreadId -> Map ThreadId (Thread s a) -> Maybe String
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads
              , let Just [TVarId]
vids' = Set TVarId -> [TVarId]
forall a. Set a -> [a]
Set.toList (Set TVarId -> [TVarId]) -> Maybe (Set TVarId) -> Maybe [TVarId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreadId -> Map ThreadId (Set TVarId) -> Maybe (Set TVarId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Set TVarId)
wokeby ]
              Trace a
trace

        StmTxAborted 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (SomeException -> SimA s b
forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl }
          Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl TraceEvent
EventTxAborted Trace a
trace)

        StmTxBlocked [SomeTVar s]
read -> do
          (SomeTVar s -> ST s ()) -> [SomeTVar s] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> ThreadId -> TVar s a -> ST s ()
forall s a. ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar ThreadId
tid TVar s a
tvar) [SomeTVar s]
read
          let vids :: [TVarId]
vids = [ TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar | SomeTVar TVar s a
tvar <- [SomeTVar s]
read ]
          Trace a
trace <- Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Blocked Thread s a
thread SimState s a
simstate
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl ([TVarId] -> TraceEvent
EventTxBlocked [TVarId]
vids) Trace a
trace)

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

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

    LabelThread ThreadId
tid' String
l SimA s b
k -> do
      let thread' :: Thread s a
thread'  = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
          threads' :: Map ThreadId (Thread s a)
threads' = (Thread s a -> Thread s a)
-> ThreadId
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
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 String
threadLabel = String -> Maybe String
forall a. a -> Maybe a
Just String
l }) ThreadId
tid' Map ThreadId (Thread s a)
threads
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace 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 -> do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (MaskingState -> SimA s b
k MaskingState
maskst) ControlStack s b a
ctl }
      Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate

    SetMaskState MaskingState
maskst' IOSim s a
action' a -> SimA s b
k -> do
      let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s a -> ControlStack s a a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl
                                               (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
action')
                                               ((a -> SimA s b)
-> MaskingState -> ControlStack s b a -> ControlStack s a a
forall b s c a.
(b -> SimA s c)
-> MaskingState -> ControlStack s c a -> ControlStack s b a
MaskFrame a -> SimA s b
k MaskingState
maskst ControlStack s b a
ctl)
                           , threadMasking :: MaskingState
threadMasking = MaskingState
maskst' }
      case MaskingState
maskst' of
        -- If we're now unmasked then check for any pending async exceptions
        MaskingState
Unmasked -> Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Interruptable Thread s a
thread' SimState s a
simstate
        MaskingState
_        -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule                 Thread s a
thread' SimState s a
simstate

    ThrowTo SomeException
e ThreadId
tid' SimA s b
_ | ThreadId
tid' ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
tid -> 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (SomeException -> SimA s b
forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl
                           , threadMasking :: MaskingState
threadMasking = MaskingState
MaskedInterruptible }
      Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate
      Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> ThreadId -> TraceEvent
EventThrowTo SomeException
e ThreadId
tid) Trace a
trace)

    ThrowTo SomeException
e ThreadId
tid' SimA s b
k -> do
      let thread' :: Thread s a
thread'   = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
          willBlock :: Bool
willBlock = case ThreadId -> Map ThreadId (Thread s a) -> Maybe (Thread s a)
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 (Thread s a -> Bool
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, ThreadId)]
threadThrowTo = (SomeException
e, ThreadId
tid) (SomeException, ThreadId)
-> [(SomeException, ThreadId)] -> [(SomeException, ThreadId)]
forall a. a -> [a] -> [a]
: Thread s a -> [(SomeException, ThreadId)]
forall s a. Thread s a -> [(SomeException, ThreadId)]
threadThrowTo Thread s a
t }
              threads' :: Map ThreadId (Thread s a)
threads'       = (Thread s a -> Thread s a)
-> ThreadId
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
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
          Trace a
trace <- Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Blocked Thread s a
thread' SimState s a
simstate { threads :: Map ThreadId (Thread s a)
threads = Map ThreadId (Thread s a)
threads' }
          Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$ Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (SomeException -> ThreadId -> TraceEvent
EventThrowTo SomeException
e ThreadId
tid')
                 (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$ Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl TraceEvent
EventThrowToBlocked
                 (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$ Trace 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 = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (SomeException -> SimA s b
forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl'
                  , threadBlocked :: Bool
threadBlocked = Bool
False
                  , threadMasking :: MaskingState
threadMasking = MaskingState
MaskedInterruptible }
              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' }
                         = ([ThreadId], SimState s a) -> SimState s a
forall a b. (a, b) -> b
snd ([ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
forall s a.
[ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId
tid'] SimState s a
simstate)
              threads'' :: Map ThreadId (Thread s a)
threads''  = (Thread s a -> Thread s a)
-> ThreadId
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
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'' }

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


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

data Deschedule = Yield | Interruptable | Blocked | Terminated

deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule :: Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Yield Thread s a
thread simstate :: SimState s a
simstate@SimState{[ThreadId]
runqueue :: [ThreadId]
runqueue :: forall s a. SimState s a -> [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).

    let runqueue' :: [ThreadId]
runqueue' = [ThreadId]
runqueue [ThreadId] -> [ThreadId] -> [ThreadId]
forall a. [a] -> [a] -> [a]
++ [Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
thread]
        threads' :: Map ThreadId (Thread s a)
threads'  = ThreadId
-> Thread s a
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
thread) Thread s a
thread Map ThreadId (Thread s a)
threads in
    SimState s a -> ST s (Trace a)
forall s a. SimState s a -> ST s (Trace a)
reschedule SimState s a
simstate { runqueue :: [ThreadId]
runqueue = [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, ThreadId)]
threadThrowTo = (SomeException
e, ThreadId
tid') : [(SomeException, ThreadId)]
etids,
                           threadLabel :: forall s a. Thread s a -> Maybe String
threadLabel   = Maybe String
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 } = do

    -- We're unmasking, but there are pending blocked async exceptions.
    -- So immediately raise the exception and unblock the blocked thread
    -- if possible.
    let thread' :: Thread s a
thread' = Thread s a
thread { threadControl :: ThreadControl s a
threadControl = SimA s b -> ControlStack s b a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (SomeException -> SimA s b
forall s a. SomeException -> SimA s a
Throw SomeException
e) ControlStack s b a
ctl
                         , threadMasking :: MaskingState
threadMasking = MaskingState
MaskedInterruptible
                         , threadThrowTo :: [(SomeException, ThreadId)]
threadThrowTo = [(SomeException, ThreadId)]
etids }
        ([ThreadId]
unblocked,
         SimState s a
simstate') = [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
forall s a.
[ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId
tid'] SimState s a
simstate
    Trace a
trace <- Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread' SimState s a
simstate'
    Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$ Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
forall a.
Time
-> ThreadId -> Maybe String -> TraceEvent -> Trace a -> Trace a
Trace Time
time ThreadId
tid Maybe String
tlbl (ThreadId -> TraceEvent
EventThrowToUnmasked ThreadId
tid')
           (Trace a -> Trace a) -> Trace a -> Trace a
forall a b. (a -> b) -> a -> b
$ [(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
forall a.
[(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
traceMany [ (Time
time, ThreadId
tid'', Maybe String
tlbl'', TraceEvent
EventThrowToWakeup)
                       | ThreadId
tid'' <- [ThreadId]
unblocked
                       , let tlbl'' :: Maybe String
tlbl'' = ThreadId -> Map ThreadId (Thread s a) -> Maybe String
forall s a. ThreadId -> Map ThreadId (Thread s a) -> Maybe String
lookupThreadLabel ThreadId
tid'' Map ThreadId (Thread s a)
threads ]
             Trace 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.
    Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread SimState s a
simstate

deschedule Deschedule
Blocked thread :: Thread s a
thread@Thread { threadThrowTo :: forall s a. Thread s a -> [(SomeException, ThreadId)]
threadThrowTo = (SomeException, ThreadId)
_ : [(SomeException, ThreadId)]
_
                                 , threadMasking :: forall s a. Thread s a -> MaskingState
threadMasking = MaskingState
maskst } SimState s a
simstate
    | MaskingState
maskst MaskingState -> MaskingState -> Bool
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.
    Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
forall s a.
Deschedule -> Thread s a -> SimState s a -> ST s (Trace a)
deschedule Deschedule
Interruptable Thread s a
thread { threadMasking :: MaskingState
threadMasking = MaskingState
Unmasked } SimState s a
simstate

deschedule Deschedule
Blocked 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} =
    let thread' :: Thread s a
thread'  = Thread s a
thread { threadBlocked :: Bool
threadBlocked = Bool
True }
        threads' :: Map ThreadId (Thread s a)
threads' = ThreadId
-> Thread s a
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Thread s a -> ThreadId
forall s a. Thread s a -> ThreadId
threadId Thread s a
thread') Thread s a
thread' Map ThreadId (Thread s a)
threads in
    SimState s a -> ST s (Trace a)
forall s a. SimState s a -> ST s (Trace 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 } = do
    -- This thread is done. If there are other threads blocked in a
    -- ThrowTo targeted at this thread then we can wake them up now.
    let wakeup :: [ThreadId]
wakeup      = ((SomeException, ThreadId) -> ThreadId)
-> [(SomeException, ThreadId)] -> [ThreadId]
forall a b. (a -> b) -> [a] -> [b]
map (SomeException, ThreadId) -> ThreadId
forall a b. (a, b) -> b
snd ([(SomeException, ThreadId)] -> [(SomeException, ThreadId)]
forall a. [a] -> [a]
reverse (Thread s a -> [(SomeException, ThreadId)]
forall s a. Thread s a -> [(SomeException, ThreadId)]
threadThrowTo Thread s a
thread))
        ([ThreadId]
unblocked,
         SimState s a
simstate') = [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
forall s a.
[ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId]
wakeup SimState s a
simstate
    Trace a
trace <- SimState s a -> ST s (Trace a)
forall s a. SimState s a -> ST s (Trace a)
reschedule SimState s a
simstate'
    Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$ [(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
forall a.
[(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
traceMany
               [ (Time
time, ThreadId
tid', Maybe String
tlbl', TraceEvent
EventThrowToWakeup)
               | ThreadId
tid' <- [ThreadId]
unblocked
               , let tlbl' :: Maybe String
tlbl' = ThreadId -> Map ThreadId (Thread s a) -> Maybe String
forall s a. ThreadId -> Map ThreadId (Thread s a) -> Maybe String
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads ]
               Trace a
trace

-- 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 (Trace a)
reschedule :: SimState s a -> ST s (Trace a)
reschedule simstate :: SimState s a
simstate@SimState{ runqueue :: forall s a. SimState s a -> [ThreadId]
runqueue = ThreadId
tid:[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 } =
    Bool -> ST s (Trace a) -> ST s (Trace a)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Thread s a) -> SimState s a -> Bool
forall s a. Maybe (Thread s a) -> SimState s a -> Bool
invariant Maybe (Thread s a)
forall a. Maybe a
Nothing SimState s a
simstate) (ST s (Trace a) -> ST s (Trace a))
-> ST s (Trace a) -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$

    let thread :: Thread s a
thread = Map ThreadId (Thread s a)
threads Map ThreadId (Thread s a) -> ThreadId -> Thread s a
forall k a. Ord k => Map k a -> k -> a
Map.! ThreadId
tid in
    Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
thread SimState s a
simstate { runqueue :: [ThreadId]
runqueue = [ThreadId]
runqueue'
                             , threads :: Map ThreadId (Thread s a)
threads  = ThreadId -> Map ThreadId (Thread s a) -> Map ThreadId (Thread s a)
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{ runqueue :: forall s a. SimState s a -> [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, OrdPSQ TimeoutId Time (TimerVars s)
timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers :: forall s a. SimState s a -> OrdPSQ TimeoutId Time (TimerVars s)
timers, curTime :: forall s a. SimState s a -> Time
curTime = Time
time } =
    Bool -> ST s (Trace a) -> ST s (Trace a)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Thread s a) -> SimState s a -> Bool
forall s a. Maybe (Thread s a) -> SimState s a -> Bool
invariant Maybe (Thread s a)
forall a. Maybe a
Nothing SimState s a
simstate) (ST s (Trace a) -> ST s (Trace a))
-> ST s (Trace a) -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$

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

      Just ([TimeoutId]
tmids, Time
time', [TimerVars s]
fired, OrdPSQ TimeoutId Time (TimerVars s)
timers') -> Bool -> ST s (Trace a) -> ST s (Trace a)
forall a. HasCallStack => Bool -> a -> a
assert (Time
time' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
time) (ST s (Trace a) -> ST s (Trace a))
-> ST s (Trace a) -> ST s (Trace a)
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 <- StmA s () -> ST s [SomeTVar s]
forall s. StmA s () -> ST s [SomeTVar s]
execAtomically' (STM s () -> StmA s ()
forall s a. STM s a -> StmA s a
runSTM (STM s () -> StmA s ()) -> STM s () -> StmA s ()
forall a b. (a -> b) -> a -> b
$ (TimerVars s -> STM s ()) -> [TimerVars s] -> STM s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TimerVars s -> STM s ()
forall (m :: * -> *) s.
(MonadSTMTx m, TVar_ m ~ TVar s) =>
TimerVars s -> m ()
timeoutAction [TimerVars s]
fired)
        ([ThreadId]
wakeup, Map ThreadId (Set TVarId)
wokeby) <- [SomeTVar s] -> ST s ([ThreadId], Map ThreadId (Set TVarId))
forall s.
[SomeTVar s] -> ST s ([ThreadId], Map ThreadId (Set TVarId))
threadsUnblockedByWrites [SomeTVar s]
written
        (SomeTVar s -> ST s ()) -> [SomeTVar s] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar s a
tvar) [SomeTVar s]
written

        let ([ThreadId]
unblocked,
             SimState s a
simstate') = [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
forall s a.
[ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId]
wakeup SimState s a
simstate
        Trace a
trace <- SimState s a -> ST s (Trace a)
forall s a. SimState s a -> ST s (Trace a)
reschedule SimState s a
simstate' { curTime :: Time
curTime = Time
time'
                                      , timers :: OrdPSQ TimeoutId Time (TimerVars s)
timers  = OrdPSQ TimeoutId Time (TimerVars s)
timers' }
        Trace a -> ST s (Trace a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Trace a -> ST s (Trace a)) -> Trace a -> ST s (Trace a)
forall a b. (a -> b) -> a -> b
$
          [(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
forall a.
[(Time, ThreadId, Maybe String, TraceEvent)] -> Trace a -> Trace a
traceMany ([ (Time
time', Int -> ThreadId
ThreadId (-Int
1), String -> Maybe String
forall a. a -> Maybe a
Just String
"timer", TimeoutId -> TraceEvent
EventTimerExpired TimeoutId
tmid)
                     | TimeoutId
tmid <- [TimeoutId]
tmids ]
                  [(Time, ThreadId, Maybe String, TraceEvent)]
-> [(Time, ThreadId, Maybe String, TraceEvent)]
-> [(Time, ThreadId, Maybe String, TraceEvent)]
forall a. [a] -> [a] -> [a]
++ [ (Time
time', ThreadId
tid', Maybe String
tlbl', [TVarId] -> TraceEvent
EventTxWakeup [TVarId]
vids)
                     | ThreadId
tid' <- [ThreadId]
unblocked
                     , let tlbl' :: Maybe String
tlbl' = ThreadId -> Map ThreadId (Thread s a) -> Maybe String
forall s a. ThreadId -> Map ThreadId (Thread s a) -> Maybe String
lookupThreadLabel ThreadId
tid' Map ThreadId (Thread s a)
threads
                     , let Just [TVarId]
vids = Set TVarId -> [TVarId]
forall a. Set a -> [a]
Set.toList (Set TVarId -> [TVarId]) -> Maybe (Set TVarId) -> Maybe [TVarId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreadId -> Map ThreadId (Set TVarId) -> Maybe (Set TVarId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid' Map ThreadId (Set TVarId)
wokeby ])
                    Trace a
trace
  where
    timeoutAction :: TimerVars s -> m ()
timeoutAction (TimerVars TVar s TimeoutState
var TVar s Bool
bvar) = do
      TimeoutState
x <- TVar_ m TimeoutState -> m TimeoutState
forall (stm :: * -> *) a. MonadSTMTx stm => TVar_ stm a -> stm a
readTVar TVar_ m TimeoutState
TVar s TimeoutState
var
      case TimeoutState
x of
        TimeoutState
TimeoutPending   -> TVar_ m TimeoutState -> TimeoutState -> m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar_ m TimeoutState
TVar s TimeoutState
var  TimeoutState
TimeoutFired
                         m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar_ m Bool -> Bool -> m ()
forall (stm :: * -> *) a.
MonadSTMTx stm =>
TVar_ stm a -> a -> stm ()
writeTVar TVar_ m Bool
TVar s Bool
bvar Bool
True
        TimeoutState
TimeoutFired     -> String -> m ()
forall a. HasCallStack => String -> a
error String
"MonadTimer(Sim): invariant violation"
        TimeoutState
TimeoutCancelled -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

unblockThreads :: [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads :: [ThreadId] -> SimState s a -> ([ThreadId], SimState s a)
unblockThreads [ThreadId]
wakeup simstate :: SimState s a
simstate@SimState {[ThreadId]
runqueue :: [ThreadId]
runqueue :: forall s a. SimState s a -> [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 :: [ThreadId]
runqueue = [ThreadId]
runqueue [ThreadId] -> [ThreadId] -> [ThreadId]
forall a. [a] -> [a] -> [a]
++ [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 ThreadId -> Map ThreadId (Thread s a) -> Maybe (Thread s a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
tid Map ThreadId (Thread s a)
threads of
                       Just Thread { threadBlocked :: forall s a. Thread s a -> Bool
threadBlocked = Bool
True } -> 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'  = (Map ThreadId (Thread s a)
 -> ThreadId -> Map ThreadId (Thread s a))
-> Map ThreadId (Thread s a)
-> [ThreadId]
-> Map ThreadId (Thread s a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
                  ((ThreadId
 -> Map ThreadId (Thread s a) -> Map ThreadId (Thread s a))
-> Map ThreadId (Thread s a)
-> ThreadId
-> Map ThreadId (Thread s a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Thread s a -> Thread s a)
-> ThreadId
-> Map ThreadId (Thread s a)
-> Map ThreadId (Thread s a)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Thread s a
t -> Thread s a
t { threadBlocked :: Bool
threadBlocked = Bool
False })))
                  Map ThreadId (Thread s a)
threads [ThreadId]
unblocked


-- | 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.
--
unwindControlStack :: forall s a.
                      SomeException
                   -> Thread s a
                   -> Either Bool (Thread s a)
unwindControlStack :: SomeException -> Thread s a -> Either Bool (Thread s a)
unwindControlStack SomeException
e Thread s a
thread =
    case Thread s a -> ThreadControl s a
forall s a. Thread s a -> ThreadControl s a
threadControl Thread s a
thread of
      ThreadControl SimA s b
_ ControlStack s b a
ctl -> MaskingState -> ControlStack s b a -> Either Bool (Thread s a)
forall s' c.
MaskingState -> ControlStack s' c a -> Either Bool (Thread s' a)
unwind (Thread s a -> MaskingState
forall s a. Thread s a -> MaskingState
threadMasking Thread s a
thread) ControlStack s b a
ctl
  where
    unwind :: forall s' c. MaskingState
           -> ControlStack s' c a -> Either Bool (Thread s' a)
    unwind :: MaskingState -> ControlStack s' c a -> Either Bool (Thread s' a)
unwind MaskingState
_  ControlStack s' c a
MainFrame                 = Bool -> Either Bool (Thread s' a)
forall a b. a -> Either a b
Left Bool
True
    unwind MaskingState
_  ControlStack s' c a
ForkFrame                 = Bool -> Either Bool (Thread s' a)
forall a b. a -> Either a b
Left Bool
False
    unwind MaskingState
_ (MaskFrame c -> SimA s' c
_k MaskingState
maskst' ControlStack s' c a
ctl) = MaskingState -> ControlStack s' c a -> Either Bool (Thread s' a)
forall s' c.
MaskingState -> ControlStack s' c a -> Either Bool (Thread s' a)
unwind MaskingState
maskst' ControlStack s' c a
ctl

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

        -- Ok! We will be able to continue the thread with the handler
        -- followed by the continuation after the catch
        Just e
e' -> Thread s' a -> Either Bool (Thread s' a)
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 = SimA s' c -> ControlStack s' c a -> ThreadControl s' a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (e -> SimA s' c
handler e
e')
                                                   ((c -> SimA s' c)
-> MaskingState -> ControlStack s' c a -> ControlStack s' c a
forall b s c a.
(b -> SimA s c)
-> MaskingState -> ControlStack s c a -> ControlStack s b a
MaskFrame c -> SimA s' c
k MaskingState
maskst ControlStack s' c a
ctl),
                     threadMasking :: MaskingState
threadMasking = MaskingState -> MaskingState -> MaskingState
forall a. Ord a => a -> a -> a
max MaskingState
maskst MaskingState
MaskedInterruptible
                   }


removeMinimums :: (Ord k, Ord p)
               => OrdPSQ k p a
               -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums :: OrdPSQ k p a -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums = \OrdPSQ k p a
psq ->
    case OrdPSQ k p a -> Maybe (k, p, a, OrdPSQ k p a)
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              -> Maybe ([k], p, [a], OrdPSQ k p a)
forall a. Maybe a
Nothing
      Just (k
k, p
p, a
x, OrdPSQ k p a
psq') -> ([k], p, [a], OrdPSQ k p a) -> Maybe ([k], p, [a], OrdPSQ k p a)
forall a. a -> Maybe a
Just ([k] -> p -> [a] -> OrdPSQ k p a -> ([k], p, [a], OrdPSQ k p a)
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 OrdPSQ a b a -> Maybe (a, b, a, OrdPSQ a b a)
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 b -> b -> Bool
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
ka -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ks) b
p (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) OrdPSQ a b a
psq'
        Maybe (a, b, a, OrdPSQ a b a)
_           -> ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
ks, b
p, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs, OrdPSQ a b a
psq)

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

lookupThreadLabel :: ThreadId -> Map ThreadId (Thread s a) -> Maybe ThreadLabel
lookupThreadLabel :: ThreadId -> Map ThreadId (Thread s a) -> Maybe String
lookupThreadLabel ThreadId
tid Map ThreadId (Thread s a)
threads = Maybe (Maybe String) -> Maybe String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Thread s a -> Maybe String
forall s a. Thread s a -> Maybe String
threadLabel (Thread s a -> Maybe String)
-> Maybe (Thread s a) -> Maybe (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreadId -> Map ThreadId (Thread s a) -> Maybe (Thread s a)
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 'Trace' with 'traceResult', or access
-- 'TraceEvent's generated by the computation with 'traceEvents'.  A slightly
-- more convenient way is exposed by 'runSimTrace'.
--
runSimTraceST :: forall s a. IOSim s a -> ST s (Trace a)
runSimTraceST :: IOSim s a -> ST s (Trace a)
runSimTraceST IOSim s a
mainAction = Thread s a -> SimState s a -> ST s (Trace a)
forall s a. Thread s a -> SimState s a -> ST s (Trace a)
schedule Thread s a
mainThread SimState s a
forall s a. SimState s a
initialState
  where
    mainThread :: Thread s a
mainThread =
      Thread :: forall s a.
ThreadId
-> ThreadControl s a
-> Bool
-> MaskingState
-> [(SomeException, ThreadId)]
-> ClockId
-> Maybe String
-> Thread s a
Thread {
        threadId :: ThreadId
threadId      = Int -> ThreadId
ThreadId Int
0,
        threadControl :: ThreadControl s a
threadControl = SimA s a -> ControlStack s a a -> ThreadControl s a
forall s b a. SimA s b -> ControlStack s b a -> ThreadControl s a
ThreadControl (IOSim s a -> SimA s a
forall s a. IOSim s a -> SimA s a
runIOSim IOSim s a
mainAction) ControlStack s a a
forall s a. ControlStack s a a
MainFrame,
        threadBlocked :: Bool
threadBlocked = Bool
False,
        threadMasking :: MaskingState
threadMasking = MaskingState
Unmasked,
        threadThrowTo :: [(SomeException, ThreadId)]
threadThrowTo = [],
        threadClockId :: ClockId
threadClockId = Int -> ClockId
ClockId Int
0,
        threadLabel :: Maybe String
threadLabel   = String -> Maybe String
forall a. a -> Maybe a
Just String
"main"
      }


--
-- Executing STM Transactions
--

data TVar s a = TVar {

       -- | The identifier of this var.
       --
       TVar s a -> TVarId
tvarId      :: !TVarId,

       -- | The var's current value
       --
       TVar s a -> STRef s a
tvarCurrent :: !(STRef s a),

       -- | A stack of undo values. This is only used while executing a
       -- transaction.
       --
       TVar s a -> STRef s [a]
tvarUndo    :: !(STRef s [a]),

       -- | Thread Ids of threads blocked on a read of this var. It is
       -- represented in reverse order of thread wakeup, without duplicates.
       --
       -- To avoid duplicates efficiently, the operations rely on a copy of the
       -- thread Ids represented as a set.
       --
       TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId))
     }

data StmTxResult s a =
       -- | A committed transaction reports the vars that were written (in order
       -- of first write) so that the scheduler can unblock other threads that
       -- were blocked in STM transactions that read any of these vars.
       --
       -- It also includes the updated TVarId name supply.
       --
       StmTxCommitted a [SomeTVar s] TVarId -- updated TVarId name supply

       -- | A blocked transaction reports the vars that were read so that the
       -- scheduler can block the thread on those vars.
       --
     | StmTxBlocked  [SomeTVar s]
     | StmTxAborted  SomeException

data SomeTVar s where
  SomeTVar :: !(TVar s a) -> SomeTVar s

data StmStack s b a where
  -- | Executing in the context of a top level 'atomically'.
  AtomicallyFrame  :: StmStack s a a

  -- | Executing in the context of the /left/ hand side of an 'orElse'
  OrElseLeftFrame  :: StmA s a                -- orElse right alternative
                   -> (a -> StmA s b)         -- subsequent continuation
                   -> Map TVarId (SomeTVar s) -- saved written vars set
                   -> [SomeTVar s]            -- saved written vars list
                   -> StmStack s b c
                   -> StmStack s a c

  -- | Executing in the context of the /right/ hand side of an 'orElse'
  OrElseRightFrame :: (a -> StmA s b)         -- subsequent continuation
                   -> Map TVarId (SomeTVar s) -- saved written vars set
                   -> [SomeTVar s]            -- saved written vars list
                   -> StmStack s b c
                   -> StmStack s a c

execAtomically :: forall s a.
                  TVarId
               -> StmA s a
               -> ST s (StmTxResult s a)
execAtomically :: TVarId -> StmA s a -> ST s (StmTxResult s a)
execAtomically =
    StmStack s a a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s a
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s a a
forall s a. StmStack s a a
AtomicallyFrame Map TVarId (SomeTVar s)
forall k a. Map k a
Map.empty Map TVarId (SomeTVar s)
forall k a. Map k a
Map.empty []
  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)
       -> TVarId                   -- var fresh name supply
       -> StmA s b
       -> ST s (StmTxResult s a)
    go :: StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl !Map TVarId (SomeTVar s)
read !Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq !TVarId
nextVid StmA s b
action = Bool -> ST s (StmTxResult s a) -> ST s (StmTxResult s a)
forall a. HasCallStack => Bool -> a -> a
assert Bool
localInvariant (ST s (StmTxResult s a) -> ST s (StmTxResult s a))
-> ST s (StmTxResult s a) -> ST s (StmTxResult s a)
forall a b. (a -> b) -> a -> b
$
                                                       case StmA s b
action of
      ReturnStm b
x -> case StmStack s b a
ctl of
        StmStack s b a
AtomicallyFrame -> do
          -- Commit each TVar
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> do
                        TVar s a -> ST s ()
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 <- TVar s a -> ST s [a]
forall s a. TVar s a -> ST s [a]
readTVarUndos TVar s a
tvar
                        Bool -> ST s () -> ST s ()
forall a. HasCallStack => Bool -> a -> a
assert ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
undos) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    ) Map TVarId (SomeTVar s)
written

          -- Return the vars written, so readers can be unblocked
          StmTxResult s b -> ST s (StmTxResult s b)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> [SomeTVar s] -> TVarId -> StmTxResult s b
forall s a. a -> [SomeTVar s] -> TVarId -> StmTxResult s a
StmTxCommitted b
x ([SomeTVar s] -> [SomeTVar s]
forall a. [a] -> [a]
reverse [SomeTVar s]
writtenSeq) TVarId
nextVid)

        OrElseLeftFrame StmA s b
_b b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq StmStack s b a
ctl' -> do
          -- Commit the TVars written in this sub-transaction that are also
          -- in the written set of the outer transaction
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar)
                    (Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
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'    = Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
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' = (SomeTVar s -> Bool) -> [SomeTVar s] -> [SomeTVar s]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(SomeTVar TVar s a
tvar) ->
                                      TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar TVarId -> Map TVarId (SomeTVar s) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map TVarId (SomeTVar s)
writtenOuter)
                                    [SomeTVar s]
writtenSeq
                         [SomeTVar s] -> [SomeTVar s] -> [SomeTVar s]
forall a. [a] -> [a] -> [a]
++ [SomeTVar s]
writtenOuterSeq
          -- Skip the orElse right hand and continue with the k continuation
          StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written' [SomeTVar s]
writtenSeq' TVarId
nextVid (b -> StmA s b
k b
x)

        OrElseRightFrame b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq StmStack s b a
ctl' -> do
          -- Commit the TVars written in this sub-transaction that are also
          -- in the written set of the outer transaction
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar)
                    (Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
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'    = Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
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' = (SomeTVar s -> Bool) -> [SomeTVar s] -> [SomeTVar s]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(SomeTVar TVar s a
tvar) ->
                                      TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar TVarId -> Map TVarId (SomeTVar s) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map TVarId (SomeTVar s)
writtenOuter)
                                    [SomeTVar s]
writtenSeq
                         [SomeTVar s] -> [SomeTVar s] -> [SomeTVar s]
forall a. [a] -> [a] -> [a]
++ [SomeTVar s]
writtenOuterSeq
          -- Continue with the k continuation
          StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written' [SomeTVar s]
writtenSeq' TVarId
nextVid (b -> StmA s b
k b
x)

      ThrowStm SomeException
e -> do
        -- Revert all the TVar writes
        (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
        StmTxResult s a -> ST s (StmTxResult s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> StmTxResult s a
forall s a. SomeException -> StmTxResult s a
StmTxAborted (SomeException -> SomeException
forall e. Exception e => e -> SomeException
toException SomeException
e))

      StmA s b
Retry -> case StmStack s b a
ctl of
        StmStack s b a
AtomicallyFrame -> do
          -- Revert all the TVar writes
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
          -- Return vars read, so the thread can block on them
          StmTxResult s a -> ST s (StmTxResult s a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([SomeTVar s] -> StmTxResult s a
forall s a. [SomeTVar s] -> StmTxResult s a
StmTxBlocked (Map TVarId (SomeTVar s) -> [SomeTVar s]
forall k a. Map k a -> [a]
Map.elems Map TVarId (SomeTVar s)
read))

        OrElseLeftFrame StmA s b
b b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq StmStack s b a
ctl' -> do
          -- Revert all the TVar writes within this orElse
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
          -- Execute the orElse right hand with an empty written set
          let ctl'' :: StmStack s b a
ctl'' = (b -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b a
-> StmStack s b a
forall a s b c.
(a -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b c
-> StmStack s a c
OrElseRightFrame b -> StmA s b
k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq StmStack s b a
ctl'
          StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl'' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
forall k a. Map k a
Map.empty [] TVarId
nextVid StmA s b
b

        OrElseRightFrame b -> StmA s b
_k Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq StmStack s b a
ctl' -> do
          -- Revert all the TVar writes within this orElse branch
          (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
revertTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
          -- Skip the continuation and propagate the retry into the outer frame
          -- using the written set for the outer frame
          StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
writtenOuter [SomeTVar s]
writtenOuterSeq TVarId
nextVid StmA s b
forall s b. StmA s b
Retry

      OrElse StmA s a
a StmA s a
b a -> StmA s b
k -> do
        -- Execute the left side in a new frame with an empty written set
        let ctl' :: StmStack s a a
ctl' = StmA s a
-> (a -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b a
-> StmStack s a a
forall s a b c.
StmA s a
-> (a -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b c
-> StmStack s a c
OrElseLeftFrame StmA s a
b a -> StmA s b
k Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq StmStack s b a
ctl
        StmStack s a a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s a
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s a a
ctl' Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
forall k a. Map k a
Map.empty [] TVarId
nextVid StmA s a
a

      NewTVar x
x TVar s x -> StmA s b
k -> do
        TVar s x
v <- TVarId -> x -> ST s (TVar s x)
forall a s. TVarId -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid x
x
        StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq (TVarId -> TVarId
forall a. Enum a => a -> a
succ TVarId
nextVid) (TVar s x -> StmA s b
k TVar s x
v)

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

      WriteTVar TVar s a
v a
x StmA s b
k
        | TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
v TVarId -> Map TVarId (SomeTVar s) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TVarId (SomeTVar s)
written -> do
            TVar s a -> a -> ST s ()
forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written [SomeTVar s]
writtenSeq TVarId
nextVid StmA s b
k
        | Bool
otherwise -> do
            TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
saveTVar TVar s a
v
            TVar s a -> a -> ST s ()
forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            let written' :: Map TVarId (SomeTVar s)
written' = TVarId
-> SomeTVar s -> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
v) (TVar s a -> SomeTVar s
forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v) Map TVarId (SomeTVar s)
written
            StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
forall b.
StmStack s b a
-> Map TVarId (SomeTVar s)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go StmStack s b a
ctl Map TVarId (SomeTVar s)
read Map TVarId (SomeTVar s)
written' (TVar s a -> SomeTVar s
forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v SomeTVar s -> [SomeTVar s] -> [SomeTVar s]
forall a. a -> [a] -> [a]
: [SomeTVar s]
writtenSeq) TVarId
nextVid StmA s b
k
      where
        localInvariant :: Bool
localInvariant =
            Map TVarId (SomeTVar s) -> Set TVarId
forall k a. Map k a -> Set k
Map.keysSet Map TVarId (SomeTVar s)
written
         Set TVarId -> Set TVarId -> Bool
forall a. Eq a => a -> a -> Bool
== [TVarId] -> Set TVarId
forall a. Ord a => [a] -> Set a
Set.fromList [ TVar s a -> TVarId
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' :: StmA s () -> ST s [SomeTVar s]
execAtomically' = Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
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 :: 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
        (SomeTVar s -> ST s ()) -> Map TVarId (SomeTVar s) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(SomeTVar TVar s a
tvar) -> TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
commitTVar TVar s a
tvar) Map TVarId (SomeTVar s)
written
        [SomeTVar s] -> ST s [SomeTVar s]
forall (m :: * -> *) a. Monad m => a -> m a
return (Map TVarId (SomeTVar s) -> [SomeTVar s]
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 <- TVar s a -> ST s a
forall s a. TVar s a -> ST s a
execReadTVar TVar s a
v
        Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
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
        | TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
v TVarId -> Map TVarId (SomeTVar s) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TVarId (SomeTVar s)
written -> do
            TVar s a -> a -> ST s ()
forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
written StmA s ()
k
        | Bool
otherwise -> do
            TVar s a -> ST s ()
forall s a. TVar s a -> ST s ()
saveTVar TVar s a
v
            TVar s a -> a -> ST s ()
forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar s a
v a
x
            let written' :: Map TVarId (SomeTVar s)
written' = TVarId
-> SomeTVar s -> Map TVarId (SomeTVar s) -> Map TVarId (SomeTVar s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
v) (TVar s a -> SomeTVar s
forall s a. TVar s a -> SomeTVar s
SomeTVar TVar s a
v) Map TVarId (SomeTVar s)
written
            Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go Map TVarId (SomeTVar s)
written' StmA s ()
k
      StmA s ()
_ -> String -> ST s [SomeTVar s]
forall a. HasCallStack => String -> a
error String
"execAtomically': only for special case of reads and writes"


execNewTVar :: TVarId -> a -> ST s (TVar s a)
execNewTVar :: TVarId -> a -> ST s (TVar s a)
execNewTVar TVarId
nextVid a
x = do
    STRef s a
tvarCurrent <- a -> ST s (STRef s a)
forall a s. a -> ST s (STRef s a)
newSTRef a
x
    STRef s [a]
tvarUndo    <- [a] -> ST s (STRef s [a])
forall a s. a -> ST s (STRef s a)
newSTRef []
    STRef s ([ThreadId], Set ThreadId)
tvarBlocked <- ([ThreadId], Set ThreadId)
-> ST s (STRef s ([ThreadId], Set ThreadId))
forall a s. a -> ST s (STRef s a)
newSTRef ([], Set ThreadId
forall a. Set a
Set.empty)
    TVar s a -> ST s (TVar s a)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar :: forall s a.
TVarId
-> STRef s a
-> STRef s [a]
-> STRef s ([ThreadId], Set ThreadId)
-> TVar s a
TVar {tvarId :: TVarId
tvarId = TVarId
nextVid, 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}

execReadTVar :: TVar s a -> ST s a
execReadTVar :: TVar s a -> ST s a
execReadTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent} = STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent

execWriteTVar :: TVar s a -> a -> ST s ()
execWriteTVar :: 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} = STRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
tvarCurrent

saveTVar :: TVar s a -> ST s ()
saveTVar :: 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  <- STRef s a -> ST s a
forall s a. STRef s a -> ST s a
readSTRef STRef s a
tvarCurrent
    [a]
vs <- STRef s [a] -> ST s [a]
forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    STRef s [a] -> [a] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs)

revertTVar :: TVar s a -> ST s ()
revertTVar :: 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
v:[a]
vs) <- STRef s [a] -> ST s [a]
forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    STRef s a -> a -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s a
tvarCurrent a
v
    STRef s [a] -> [a] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo    [a]
vs

commitTVar :: TVar s a -> ST s ()
commitTVar :: 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
    -- pop the undo stack, leaving the current value unchanged
    (a
_:[a]
vs) <- STRef s [a] -> ST s [a]
forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
    STRef s [a] -> [a] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [a]
tvarUndo [a]
vs

readTVarUndos :: TVar s a -> ST s [a]
readTVarUndos :: 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} = STRef s [a] -> ST s [a]
forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo


--
-- Blocking and unblocking on TVars
--

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

blockThreadOnTVar :: ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar :: 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) <- STRef s ([ThreadId], Set ThreadId)
-> ST s ([ThreadId], Set ThreadId)
forall s a. STRef s a -> ST s a
readSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked
    Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ThreadId
tid ThreadId -> Set ThreadId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set ThreadId
tidsSet) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
      let !tids' :: [ThreadId]
tids'    = ThreadId
tid ThreadId -> [ThreadId] -> [ThreadId]
forall a. a -> [a] -> [a]
: [ThreadId]
tids
          !tidsSet' :: Set ThreadId
tidsSet' = ThreadId -> Set ThreadId -> Set ThreadId
forall a. Ord a => a -> Set a -> Set a
Set.insert ThreadId
tid Set ThreadId
tidsSet
      STRef s ([ThreadId], Set ThreadId)
-> ([ThreadId], Set ThreadId) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked ([ThreadId]
tids', Set ThreadId
tidsSet')

unblockAllThreadsFromTVar :: TVar s a -> ST s ()
unblockAllThreadsFromTVar :: 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
    STRef s ([ThreadId], Set ThreadId)
-> ([ThreadId], Set ThreadId) -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s ([ThreadId], Set ThreadId)
tvarBlocked ([], Set ThreadId
forall a. Set a
Set.empty)

-- | 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 TVarId))
threadsUnblockedByWrites :: [SomeTVar s] -> ST s ([ThreadId], Map ThreadId (Set TVarId))
threadsUnblockedByWrites [SomeTVar s]
written = do
  [(TVarId, [ThreadId])]
tidss <- [ST s (TVarId, [ThreadId])] -> ST s [(TVarId, [ThreadId])]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
             [ (,) (TVar s a -> TVarId
forall s a. TVar s a -> TVarId
tvarId TVar s a
tvar) ([ThreadId] -> (TVarId, [ThreadId]))
-> ST s [ThreadId] -> ST s (TVarId, [ThreadId])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar s a -> ST s [ThreadId]
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 = [ThreadId] -> [ThreadId]
forall a. Ord a => [a] -> [a]
ordNub [ ThreadId
tid | (TVarId
_vid, [ThreadId]
tids) <- [(TVarId, [ThreadId])]
tidss, ThreadId
tid <- [ThreadId] -> [ThreadId]
forall a. [a] -> [a]
reverse [ThreadId]
tids ]
      wokeby :: Map ThreadId (Set TVarId)
wokeby = (Set TVarId -> Set TVarId -> Set TVarId)
-> [(ThreadId, Set TVarId)] -> Map ThreadId (Set TVarId)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set TVarId -> Set TVarId -> Set TVarId
forall a. Ord a => Set a -> Set a -> Set a
Set.union
                                [ (ThreadId
tid, TVarId -> Set TVarId
forall a. a -> Set a
Set.singleton TVarId
vid)
                                | (TVarId
vid, [ThreadId]
tids) <- [(TVarId, [ThreadId])]
tidss
                                , ThreadId
tid <- [ThreadId]
tids ]
  ([ThreadId], Map ThreadId (Set TVarId))
-> ST s ([ThreadId], Map ThreadId (Set TVarId))
forall (m :: * -> *) a. Monad m => a -> m a
return ([ThreadId]
wakeup, Map ThreadId (Set TVarId)
wokeby)

ordNub :: Ord a => [a] -> [a]
ordNub :: [a] -> [a]
ordNub = Set a -> [a] -> [a]
forall a. Ord a => Set a -> [a] -> [a]
go Set a
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 a -> Set a -> Bool
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs