diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Revsion history of io-sim +## 1.2.0.0 + +### Breaking changes + +* `selectTraceEvents`, `selectTraceEvents'` catpure time of events. +* Added select function which capture the time of the trace events: + - `selectTraceEventsDynamicWithTime` + - `selectTraceEventsDynamicWithTime'` + - `selectTraceEventsSayWithTime` + - `selectTraceEventsSayWithTime'` + +### Non breaking changes + +* Provide `MonadInspectMVar` instance for `IOSim`. +- Added NFData & NoThunks instances for `ThreadId` + ## 1.1.0.0 ### Non breaking changes diff --git a/io-sim.cabal b/io-sim.cabal --- a/io-sim.cabal +++ b/io-sim.cabal @@ -1,22 +1,20 @@ cabal-version: 3.0 name: io-sim -version: 1.1.0.0 +version: 1.2.0.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurency (base, async), stm, synchronous and asynchronous exceptions, timeouts & delays, dynamic traces, and more. license: Apache-2.0 -license-files: - LICENSE - NOTICE +license-files: LICENSE NOTICE copyright: 2022-2023 Input Output Global Inc (IOG) author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Testing build-type: Simple -extra-source-files: CHANGELOG.md - README.md +extra-doc-files: CHANGELOG.md README.md +bug-reports: https://github.com/input-output-hk/io-sim/issues tested-with: GHC == { 8.10, 9.2, 9.4, 9.6 } flag asserts @@ -77,14 +75,15 @@ ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.19, - io-classes ^>=1.1, + io-classes ^>=1.2, exceptions >=0.10, containers, + deepseq, nothunks, parallel, psqueues >=0.2 && <0.3, - strict-stm >=1.0 && <1.2, - si-timers >=1.0 && <1.2, + strict-stm ^>=1.2, + si-timers ^>=1.2, time >=1.9.1 && <1.13, quiet, QuickCheck, diff --git a/src/Control/Monad/IOSim.hs b/src/Control/Monad/IOSim.hs --- a/src/Control/Monad/IOSim.hs +++ b/src/Control/Monad/IOSim.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module Control.Monad.IOSim @@ -58,9 +59,13 @@ , selectTraceEvents , selectTraceEvents' , selectTraceEventsDynamic + , selectTraceEventsDynamicWithTime , selectTraceEventsDynamic' + , selectTraceEventsDynamicWithTime' , selectTraceEventsSay + , selectTraceEventsSayWithTime , selectTraceEventsSay' + , selectTraceEventsSayWithTime' , selectTraceRaces -- *** trace selectors , traceSelectTraceEvents @@ -108,7 +113,7 @@ selectTraceEvents - :: (SimEventType -> Maybe b) + :: (Time -> SimEventType -> Maybe b) -> SimTrace a -> [b] selectTraceEvents fn = @@ -124,7 +129,7 @@ . traceSelectTraceEvents fn selectTraceEvents' - :: (SimEventType -> Maybe b) + :: (Time -> SimEventType -> Maybe b) -> SimTrace a -> [b] selectTraceEvents' fn = @@ -177,20 +182,38 @@ selectTraceEventsDynamic :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic = selectTraceEvents fn where - fn :: SimEventType -> Maybe b - fn (EventLog dyn) = fromDynamic dyn - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe b + fn _ (EventLog dyn) = fromDynamic dyn + fn _ _ = Nothing +-- | Like 'selectTraceEventsDynamic' but also captures time of the trace event. +-- +selectTraceEventsDynamicWithTime :: forall a b. Typeable b => SimTrace a -> [(Time, b)] +selectTraceEventsDynamicWithTime = selectTraceEvents fn + where + fn :: Time -> SimEventType -> Maybe (Time, b) + fn t (EventLog dyn) = (t,) <$> fromDynamic dyn + fn _ _ = Nothing + -- | Like 'selectTraceEventsDynamic' but returns partial trace if an exception -- is found in it. -- selectTraceEventsDynamic' :: forall a b. Typeable b => SimTrace a -> [b] selectTraceEventsDynamic' = selectTraceEvents' fn where - fn :: SimEventType -> Maybe b - fn (EventLog dyn) = fromDynamic dyn - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe b + fn _ (EventLog dyn) = fromDynamic dyn + fn _ _ = Nothing +-- | Like `selectTraceEventsDynamic'` but also captures time of the trace event. +-- +selectTraceEventsDynamicWithTime' :: forall a b. Typeable b => SimTrace a -> [(Time, b)] +selectTraceEventsDynamicWithTime' = selectTraceEvents' fn + where + fn :: Time -> SimEventType -> Maybe (Time, b) + fn t (EventLog dyn) = (t,) <$> fromDynamic dyn + fn _ _ = Nothing + -- | Get a trace of 'EventSay'. -- -- For convenience, this throws exceptions for abnormal sim termination. @@ -198,20 +221,38 @@ selectTraceEventsSay :: SimTrace a -> [String] selectTraceEventsSay = selectTraceEvents fn where - fn :: SimEventType -> Maybe String - fn (EventSay s) = Just s - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe String + fn _ (EventSay s) = Just s + fn _ _ = Nothing +-- | Like 'selectTraceEventsSay' but also captures time of the trace event. +-- +selectTraceEventsSayWithTime :: SimTrace a -> [(Time, String)] +selectTraceEventsSayWithTime = selectTraceEvents fn + where + fn :: Time -> SimEventType -> Maybe (Time, String) + fn t (EventSay s) = Just (t, s) + fn _ _ = Nothing + -- | Like 'selectTraceEventsSay' but return partial trace if an exception is -- found in it. -- selectTraceEventsSay' :: SimTrace a -> [String] selectTraceEventsSay' = selectTraceEvents' fn where - fn :: SimEventType -> Maybe String - fn (EventSay s) = Just s - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe String + fn _ (EventSay s) = Just s + fn _ _ = Nothing +-- | Like `selectTraceEventsSay'` but also captures time of the trace event. +-- +selectTraceEventsSayWithTime' :: SimTrace a -> [(Time, String)] +selectTraceEventsSayWithTime' = selectTraceEvents' fn + where + fn :: Time -> SimEventType -> Maybe (Time, String) + fn t (EventSay s) = Just (t, s) + fn _ _ = Nothing + -- | Print all 'EventSay' to the console. -- -- For convenience, this throws exceptions for abnormal sim termination. @@ -223,7 +264,7 @@ -- | The most general select function. It is a _total_ function. -- traceSelectTraceEvents - :: (SimEventType -> Maybe b) + :: (Time -> SimEventType -> Maybe b) -> SimTrace a -> Trace (SimResult a) b traceSelectTraceEvents fn = bifoldr ( \ v _acc -> Nil v ) @@ -231,11 +272,11 @@ -> case eventCtx of SimRacesFound _ -> acc SimEvent{} -> - case fn (seType eventCtx) of + case fn (seTime eventCtx) (seType eventCtx) of Nothing -> acc Just b -> Cons b acc SimPOREvent{} -> - case fn (seType eventCtx) of + case fn (seTime eventCtx) (seType eventCtx) of Nothing -> acc Just b -> Cons b acc ) @@ -247,9 +288,9 @@ => SimTrace a -> Trace (SimResult a) b traceSelectTraceEventsDynamic = traceSelectTraceEvents fn where - fn :: SimEventType -> Maybe b - fn (EventLog dyn) = fromDynamic dyn - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe b + fn _ (EventLog dyn) = fromDynamic dyn + fn _ _ = Nothing -- | Select say events. It is a _total_ function. @@ -257,9 +298,9 @@ traceSelectTraceEventsSay :: forall a. SimTrace a -> Trace (SimResult a) String traceSelectTraceEventsSay = traceSelectTraceEvents fn where - fn :: SimEventType -> Maybe String - fn (EventSay s) = Just s - fn _ = Nothing + fn :: Time -> SimEventType -> Maybe String + fn _ (EventSay s) = Just s + fn _ _ = Nothing -- | Simulation terminated a failure. -- diff --git a/src/Control/Monad/IOSim/CommonTypes.hs b/src/Control/Monad/IOSim/CommonTypes.hs --- a/src/Control/Monad/IOSim/CommonTypes.hs +++ b/src/Control/Monad/IOSim/CommonTypes.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,12 +9,16 @@ -- module Control.Monad.IOSim.CommonTypes where +import Control.DeepSeq (NFData (..)) import Control.Monad.Class.MonadSTM (TraceValue) import Control.Monad.ST.Lazy +import NoThunks.Class + import Data.Map (Map) import Data.STRef.Lazy import Data.Set (Set) +import GHC.Generics -- | A thread id. @@ -23,7 +30,10 @@ -- data ThreadId = RacyThreadId [Int] | ThreadId [Int] -- non racy threads have higher priority - deriving (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass NFData + deriving anyclass NoThunks + childThreadId :: ThreadId -> Int -> ThreadId childThreadId (RacyThreadId is) i = RacyThreadId (is ++ [i]) diff --git a/src/Control/Monad/IOSim/Types.hs b/src/Control/Monad/IOSim/Types.hs --- a/src/Control/Monad/IOSim/Types.hs +++ b/src/Control/Monad/IOSim/Types.hs @@ -567,6 +567,14 @@ tryReadMVar = tryReadMVarDefault isEmptyMVar = isEmptyMVarDefault +instance MonadInspectMVar (IOSim s) where + type InspectMVarMonad (IOSim s) = ST s + inspectMVar p (MVar tvar) = do + st <- inspectTVar p tvar + case st of + MVarEmpty _ _ -> pure Nothing + MVarFull x _ -> pure (Just x) + data Async s a = Async !ThreadId (STM s (Either SomeException a)) instance Eq (Async s a) where