{-# 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 #-}
{-# 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 { forall s a. 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 :: forall s a. 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 :: forall a s. Typeable a => 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 { forall s a. 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 :: forall s a. 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
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
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)
instance Functor (IOSim s) where
{-# INLINE fmap #-}
fmap :: forall a b. (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 -> forall r. (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 :: forall a. 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 (<*>) #-}
<*> :: forall a b. 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) -> forall r. ((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 -> forall r. (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 (*>) #-}
*> :: forall a b. 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 -> forall r. (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 -> forall r. (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 :: forall a. a -> IOSim s a
return = a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE (>>=) #-}
>>= :: forall a b. 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 -> forall r. (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 -> forall r. (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 (>>) #-}
>> :: forall a b. 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 :: forall a. 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 :: forall a b. (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 -> forall r. (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 :: forall a. 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 (<*>) #-}
<*> :: forall a b. 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) -> forall r. ((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 -> forall r. (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 (*>) #-}
*> :: forall a b. 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 -> forall r. (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 -> forall r. (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 :: forall a. a -> STM s a
return = a -> STM s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE (>>=) #-}
>>= :: forall a b. 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 -> forall r. (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 -> forall r. (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 (>>) #-}
>> :: forall a b. 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 :: forall a. 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 :: forall a. STM s a
empty = STM s a
forall (stm :: * -> *) a. MonadSTMTx stm => stm a
retry
<|> :: forall a. 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 :: forall e a. Exception e => 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 :: forall a. 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 :: forall e a. Exception e => 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 :: forall e a. Exception e => 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)
bracket :: forall a b c.
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 :: forall a b. 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 :: forall e a. Exception e => 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 :: forall e a.
Exception e =>
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 a s c b.
Exception a =>
SimA s c -> (a -> SimA s c) -> (c -> 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 :: forall e a.
Exception e =>
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 b.
((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 b.
((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 b.
((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 b.
((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 :: forall a b c.
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 :: forall s. 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 :: forall s a. 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 :: forall s a. 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 :: forall s a. 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 :: forall e. Exception e => 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 :: forall a. 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 a s b. a -> (TVar s a -> StmA s b) -> StmA s b
NewTVar a
x TVar s a -> StmA s r
k
readTVar :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. 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 :: forall a. HasCallStack => 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 :: forall a. a -> IOSim s (TMVar (IOSim s) a)
newTMVarIO = a -> IOSim s (TMVar_ (STM (IOSim s)) a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TMVarDefault m a)
newTMVarIODefault
newEmptyTMVarIO :: forall a. IOSim s (TMVar (IOSim s) a)
newEmptyTMVarIO = IOSim s (TMVar_ (STM (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 :: forall a b. (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 :: forall a. Async s a -> STM s (Either SomeException a)
waitCatchSTM (Async ThreadId
_ STM s (Either SomeException a)
w) = STM s (Either SomeException a)
w
pollSTM :: forall a. 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 :: forall a. 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 :: forall a.
Proxy (IOSim s) -> Async (IOSim s) a -> ThreadId (IOSim s)
asyncThreadId Proxy (IOSim s)
_proxy (Async ThreadId
tid STM s (Either SomeException a)
_) = ThreadId (IOSim s)
ThreadId
tid
cancel :: forall a. Async (IOSim s) a -> IOSim s ()
cancel a :: Async (IOSim s) a
a@(Async ThreadId
tid STM s (Either SomeException a)
_) = 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 :: forall e a. Exception e => Async (IOSim s) a -> e -> IOSim s ()
cancelWith a :: Async (IOSim s) a
a@(Async ThreadId
tid STM s (Either SomeException a)
_) 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 a.
((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 b. (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 :: forall s a. 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
setCurrentTime :: UTCTime -> IOSim s ()
setCurrentTime :: forall s. 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 ())
unshareClock :: IOSim s ()
unshareClock :: forall s. 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
instance MonadTimer (IOSim s) where
data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !(TVar s Bool) !TimeoutId
| NegativeTimeout !TimeoutId
readTimeout :: Timeout (IOSim s) -> STM (IOSim s) TimeoutState
readTimeout (Timeout TVar s TimeoutState
var TVar s Bool
_bvar TimeoutId
_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 TimeoutId
_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 :: forall a. 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 TVar s TimeoutState
_ TVar s Bool
_ TimeoutId
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 TVar s TimeoutState
_var TVar s Bool
bvar TimeoutId
_) -> 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
newtype EventlogEvent = EventlogEvent String
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
data Thread s a = Thread {
forall s a. Thread s a -> ThreadId
threadId :: !ThreadId,
forall s a. Thread s a -> ThreadControl s a
threadControl :: !(ThreadControl s a),
forall s a. Thread s a -> Bool
threadBlocked :: !Bool,
forall s a. Thread s a -> MaskingState
threadMasking :: !MaskingState,
forall s a. Thread s a -> [(SomeException, ThreadId)]
threadThrowTo :: ![(SomeException, ThreadId)],
forall s a. Thread s a -> ClockId
threadClockId :: !ClockId,
forall s a. Thread s a -> Maybe String
threadLabel :: Maybe ThreadLabel
}
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)
-> MaskingState
-> ControlStack s c a
-> ControlStack s b a
CatchFrame :: Exception e
=> (e -> SimA s b)
-> (b -> SimA s c)
-> 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
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
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
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
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
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 :: forall s a. Map ThreadId (Thread s a) -> [LabeledThread]
labeledThreads Map ThreadId (Thread s a)
threadMap =
(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
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
| EventThrowToBlocked
| EventThrowToWakeup
| EventThrowToUnmasked ThreadId
| EventThreadForked ThreadId
| EventThreadFinished
| EventThreadUnhandled SomeException
| EventTxCommitted [TVarId]
[TVarId]
| EventTxAborted
| EventTxBlocked [TVarId]
| EventTxWakeup [TVarId]
| 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
data TimerVars s = TimerVars !(TVar s TimeoutState) !(TVar s Bool)
data SimState s a = SimState {
forall s a. SimState s a -> [ThreadId]
runqueue :: ![ThreadId],
forall s a. SimState s a -> Map ThreadId (Thread s a)
threads :: !(Map ThreadId (Thread s a)),
forall s a. SimState s a -> Time
curTime :: !Time,
forall s a. SimState s a -> OrdPSQ TimeoutId Time (TimerVars s)
timers :: !(OrdPSQ TimeoutId Time (TimerVars s)),
forall s a. SimState s a -> Map ClockId UTCTime
clocks :: !(Map ClockId UTCTime),
forall s a. SimState s a -> ThreadId
nextTid :: !ThreadId,
forall s a. SimState s a -> TVarId
nextVid :: !TVarId,
forall s a. SimState s a -> TimeoutId
nextTmid :: !TimeoutId
}
initialState :: SimState s a
initialState :: forall s a. 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 :: forall s a. 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 ]
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 :: Thread s a -> SimState s a -> ST s (Trace a)
schedule :: forall s a. 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 ->
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
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
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (b -> SimA s c
k b
x) ControlStack s c a
ctl'
, threadMasking :: MaskingState
threadMasking = MaskingState
maskst' }
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
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (b -> SimA s c
k b
x) ControlStack s c a
ctl' }
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
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
| Bool
isMain ->
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
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
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 a a. SimA s a -> ControlStack s a 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 a s b c a.
Exception a =>
(a -> SimA s b)
-> (b -> SimA s c) -> ControlStack s c a -> ControlStack s b a
CatchFrame e -> SimA s a
handler a -> SimA s b
k ControlStack s b a
ctl) }
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
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 a a. SimA s a -> ControlStack s a 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
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
whnf) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (Time -> SimA s b
k Time
time) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (UTCTime -> SimA s b
k UTCTime
walltime) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
simstate' :: SimState s a
simstate' = SimState s a
simstate { clocks :: Map ClockId UTCTime
clocks = 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
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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl
, threadClockId :: ClockId
threadClockId = ClockId
clockid' }
simstate' :: SimState s a
simstate' = SimState s a
simstate { clocks :: Map ClockId UTCTime
clocks = 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'
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a 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)
UpdateTimeout (Timeout TVar s TimeoutState
_tvar TVar s Bool
_tvar' TimeoutId
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 a a. SimA s a -> ControlStack s a 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 s TimeoutState
_tvar TVar s Bool
_tvar' TimeoutId
tmid) DiffTime
d SimA s b
k -> do
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 a a. SimA s a -> ControlStack s a 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)
UpdateTimeout (NegativeTimeout TimeoutId
_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 a a. SimA s a -> ControlStack s a 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 s TimeoutState
_tvar TVar s Bool
_tvar' TimeoutId
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 a a. SimA s a -> ControlStack s a 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)
CancelTimeout (NegativeTimeout TimeoutId
_tmid) 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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (ThreadId -> SimA s b
k ThreadId
tid') ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (a -> SimA s b
k a
x) ControlStack s b a
ctl }
([ThreadId]
unblocked,
SimState s a
simstate') = [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 ]
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
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (ThreadId -> SimA s b
k ThreadId
tid) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
threads' :: Map ThreadId (Thread s a)
threads' = (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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl (MaskingState -> SimA s b
k MaskingState
maskst) ControlStack s b a
ctl }
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 a a. SimA s a -> ControlStack s a 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 a a.
(b -> SimA s a)
-> MaskingState -> ControlStack s a a -> ControlStack s b a
MaskFrame a -> SimA s b
k MaskingState
maskst ControlStack s b a
ctl)
, threadMasking :: MaskingState
threadMasking = MaskingState
maskst' }
case MaskingState
maskst' of
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
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 a a. SimA s a -> ControlStack s a 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 a a. SimA s a -> ControlStack s a a -> ThreadControl s a
ThreadControl SimA s b
k ControlStack s b a
ctl }
willBlock :: Bool
willBlock = case 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
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
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 a a. SimA s a -> ControlStack s a 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 :: forall s a. 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
| 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 :: forall s a.
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} =
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
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 a a. SimA s a -> ControlStack s a 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 =
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 =
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
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
reschedule :: SimState s a -> ST s (Trace a)
reschedule :: forall s a. 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 }
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
$
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
[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 :: forall s a.
[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} =
([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
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
]
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
unwindControlStack :: forall s a.
SomeException
-> Thread s a
-> Either Bool (Thread s a)
unwindControlStack :: forall s a. 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 :: forall s' c.
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
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
Just e
e' -> Thread s' a -> Either Bool (Thread s' a)
forall a b. b -> Either a b
Right Thread s a
thread {
threadControl :: ThreadControl s' a
threadControl = SimA s' c -> ControlStack s' c a -> ThreadControl s' a
forall s a a. SimA s a -> ControlStack s a 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 a a.
(b -> SimA s a)
-> MaskingState -> ControlStack s a a -> ControlStack s b a
MaskFrame c -> SimA s' c
k MaskingState
maskst ControlStack s' c a
ctl),
threadMasking :: MaskingState
threadMasking = MaskingState -> MaskingState -> 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 :: forall k p a.
(Ord k, Ord p) =>
OrdPSQ k p a -> Maybe ([k], p, [a], OrdPSQ k p a)
removeMinimums = \OrdPSQ k p a
psq ->
case 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 :: forall a.
[(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 :: forall s a. 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)
runSimTraceST :: forall s a. IOSim s a -> ST s (Trace a)
runSimTraceST :: forall s a. 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 a a. SimA s a -> ControlStack s a 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"
}
data TVar s a = TVar {
forall s a. TVar s a -> TVarId
tvarId :: !TVarId,
forall s a. TVar s a -> STRef s a
tvarCurrent :: !(STRef s a),
forall s a. TVar s a -> STRef s [a]
tvarUndo :: !(STRef s [a]),
forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: !(STRef s ([ThreadId], Set ThreadId))
}
data StmTxResult s a =
StmTxCommitted a [SomeTVar s] TVarId
| StmTxBlocked [SomeTVar s]
| StmTxAborted SomeException
data SomeTVar s where
SomeTVar :: !(TVar s a) -> SomeTVar s
data StmStack s b a where
AtomicallyFrame :: StmStack s a a
OrElseLeftFrame :: StmA s a
-> (a -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b c
-> StmStack s a c
OrElseRightFrame :: (a -> StmA s b)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s b c
-> StmStack s a c
execAtomically :: forall s a.
TVarId
-> StmA s a
-> ST s (StmTxResult s a)
execAtomically :: forall s a. 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)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> TVarId
-> StmA s b
-> ST s (StmTxResult s a)
go :: 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
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
(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
[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
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
(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)
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
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
(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)
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
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
(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
(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 ([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
(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
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 a c.
(a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s a 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
(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
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
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 a c.
StmA s a
-> (a -> StmA s a)
-> Map TVarId (SomeTVar s)
-> [SomeTVar s]
-> StmStack s a 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 ]
execAtomically' :: StmA s () -> ST s [SomeTVar s]
execAtomically' :: forall s. 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)
-> StmA s ()
-> ST s [SomeTVar s]
go :: forall s. Map TVarId (SomeTVar s) -> StmA s () -> ST s [SomeTVar s]
go !Map TVarId (SomeTVar s)
written StmA s ()
action = case StmA s ()
action of
ReturnStm () -> do
(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 :: forall a s. 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 :: forall s a. 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 :: forall s a. TVar s a -> a -> ST s ()
execWriteTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent} = 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 :: forall s a. TVar s a -> ST s ()
saveTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
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 :: forall s a. TVar s a -> ST s ()
revertTVar TVar{STRef s a
tvarCurrent :: STRef s a
tvarCurrent :: forall s a. TVar s a -> STRef s a
tvarCurrent, STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
(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 :: forall s a. TVar s a -> ST s ()
commitTVar TVar{STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = do
(a
_:[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 :: forall s a. TVar s a -> ST s [a]
readTVarUndos TVar{STRef s [a]
tvarUndo :: STRef s [a]
tvarUndo :: forall s a. TVar s a -> STRef s [a]
tvarUndo} = STRef s [a] -> ST s [a]
forall s a. STRef s a -> ST s a
readSTRef STRef s [a]
tvarUndo
readTVarBlockedThreads :: TVar s a -> ST s [ThreadId]
readTVarBlockedThreads :: forall s a. TVar s a -> ST s [ThreadId]
readTVarBlockedThreads TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = ([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 :: forall s a. ThreadId -> TVar s a -> ST s ()
blockThreadOnTVar ThreadId
tid TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = do
([ThreadId]
tids, Set ThreadId
tidsSet) <- 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 :: forall s a. TVar s a -> ST s ()
unblockAllThreadsFromTVar TVar{STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: STRef s ([ThreadId], Set ThreadId)
tvarBlocked :: forall s a. TVar s a -> STRef s ([ThreadId], Set ThreadId)
tvarBlocked} = do
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)
threadsUnblockedByWrites :: [SomeTVar s]
-> ST s ([ThreadId], Map ThreadId (Set TVarId))
threadsUnblockedByWrites :: forall s.
[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 ]
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 :: forall a. Ord a => [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