io-sim 1.8.0.1 → 1.9.0.0
raw patch · 9 files changed
+135/−16 lines, 9 filesdep ~basedep ~io-classesdep ~time
Dependency ranges changed: base, io-classes, time
Files
- CHANGELOG.md +16/−1
- io-sim.cabal +3/−3
- src/Control/Monad/IOSim.hs +12/−2
- src/Control/Monad/IOSim/CommonTypes.hs +12/−0
- src/Control/Monad/IOSim/Internal.hs +12/−3
- src/Control/Monad/IOSim/STM.hs +0/−2
- src/Control/Monad/IOSim/Types.hs +22/−4
- src/Control/Monad/IOSimPOR/Internal.hs +10/−1
- test/Test/Control/Monad/IOSim.hs +48/−0
CHANGELOG.md view
@@ -6,7 +6,22 @@ ### Non-breaking changes -### 1.8.0.1+## 1.9.0.0++The version is bumped to `1.9` in sync with `io-classes-1.9`.++### Non-breaking changes++* Added support for unique symbol generation à la `Data.Unique`.+* Removed a misleading internal comment.+* Fixed error handling in `traceResult` so one can combine it (or ather APIs+ which are based on it: `runSim`, `runSimOrThrow`, or `runSimStrictShutdown`)+ with `within` or `discardAfter` from `QuickCheck`. See the test suite how to+ use `discardAfter` with `IOSim`.+* Round `si-timers` API (`MonadDelay`, `MonadTimer`) to microsecond to match+ `IO` behaviour.++## 1.8.0.1 * Added support for `ghc-9.2`.
io-sim.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: io-sim-version: 1.8.0.1+version: 1.9.0.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurrency (base & async style), stm,@@ -66,7 +66,7 @@ default-extensions: GADTs build-depends: base >=4.16 && <4.22, io-classes:{io-classes,strict-stm,si-timers}- ^>=1.6 || ^>= 1.7 || ^>= 1.8,+ ^>=1.9, exceptions >=0.10, containers, deepseq,@@ -74,7 +74,7 @@ nothunks, primitive >=0.7 && <0.11, psqueues >=0.2 && <0.3,- time >=1.9.1 && <1.13,+ time >=1.9.1 && <1.16, quiet, QuickCheck, parallel
src/Control/Monad/IOSim.hs view
@@ -48,6 +48,7 @@ , ThreadLabel , IOSimThreadId (..) , Labelled (..)+ , Unique -- ** Dynamic Tracing , traceM , traceSTM@@ -98,7 +99,7 @@ import Data.List.Trace (Trace (..)) -import Control.Exception (throw)+import Control.Exception (SomeAsyncException (..), throw) import Control.Monad.ST.Lazy @@ -421,7 +422,16 @@ where eval :: SimTrace a -> IO (Either Failure a) eval a = do- r <- try (evaluate a)+ -- NOTE: It's fine to let asynchronous exceptions pass through. The only+ -- way simulation could raise them is by using `throw` in pure code, while+ -- `throwIO` in the simulation will be captured as `FailureException`. So+ -- we can safely assume asynchronous exceptions are coming from the+ -- environment running the simulation, e.g. `QuickCheck`, as in the case+ -- of `within` or `discardAfter` operators.+ r <- tryJust (\e -> case fromException @SomeAsyncException e of+ Just _ -> Nothing+ Nothing -> Just e)+ (evaluate a) case r of Left e -> return (Left (FailureEvaluation e)) Right _ -> go a
src/Control/Monad/IOSim/CommonTypes.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-}+{-# LANGUAGE RoleAnnotations #-} -- | Common types shared between `IOSim` and `IOSimPOR`. --@@ -28,6 +29,7 @@ , BlockedReason (..) , Labelled (..) , ppLabelled+ , Unique (..) -- * Utils , ppList ) where@@ -201,6 +203,16 @@ ppLabelled :: (a -> String) -> Labelled a -> String ppLabelled pp Labelled { l_labelled = a, l_label = Nothing } = pp a ppLabelled pp Labelled { l_labelled = a, l_label = Just lbl } = concat ["Labelled ", pp a, " ", lbl]++-- | Abstract unique symbols à la "Data.Unique".+newtype Unique s = MkUnique{ unMkUnique :: Integer }+ deriving stock (Eq, Ord)+ deriving newtype NFData+type role Unique nominal++instance Hashable (Unique s) where+ hash = fromInteger . unMkUnique+ hashWithSalt = defaultHashWithSalt -- -- Utils
src/Control/Monad/IOSim/Internal.hs view
@@ -143,7 +143,8 @@ -- | list of clocks clocks :: !(Map ClockId UTCTime), nextVid :: !VarId, -- ^ next unused 'VarId'- nextTmid :: !TimeoutId -- ^ next unused 'TimeoutId'+ nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId'+ nextUniq :: !(Unique s) -- ^ next unused @'Unique' s@ } initialState :: SimState s a@@ -155,7 +156,8 @@ timers = PSQ.empty, clocks = Map.singleton (ClockId []) epoch1970, nextVid = 0,- nextTmid = TimeoutId 0+ nextTmid = TimeoutId 0,+ nextUniq = MkUnique 0 } where epoch1970 = UTCTime (fromGregorian 1970 1 1) 0@@ -197,7 +199,7 @@ threads, timers, clocks,- nextVid, nextTmid,+ nextVid, nextTmid, nextUniq, curTime = time } = invariant (Just thread) simstate $@@ -630,6 +632,13 @@ LiftST (lazyToStrictST (writeSTRef r x')) (\() -> k x') thread' = thread { threadControl = ThreadControl k' ctl } schedule thread' simstate++ NewUnique k -> do+ let thread' = thread{ threadControl = ThreadControl (k nextUniq) ctl }+ n = unMkUnique nextUniq+ simstate' = simstate{ nextUniq = MkUnique (n + 1) }+ SimTrace time tid tlbl (EventUniqueCreated n)+ <$> schedule thread' simstate' threadInterruptible :: Thread s a -> Bool
src/Control/Monad/IOSim/STM.hs view
@@ -148,8 +148,6 @@ case reverse ys of [] -> return Nothing - -- NB. lazy: we want the transaction to be- -- short, otherwise it will conflict (z:zs) -> do writeTVar queue $! (zs, r', [], w) return (Just z)
src/Control/Monad/IOSim/Types.hs view
@@ -93,6 +93,7 @@ import Control.Monad.Class.MonadTimer import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) import Control.Monad.Class.MonadTimer.SI qualified as SI+import Control.Monad.Class.MonadUnique import Control.Monad.Primitive qualified as Prim import Control.Monad.ST.Lazy import Control.Monad.ST.Strict qualified as StrictST@@ -104,6 +105,7 @@ import Data.Bifoldable import Data.Bifunctor (bimap) import Data.Dynamic (Dynamic, toDyn)+import Data.Hashable (Hashable (hash)) import Data.List.Trace qualified as Trace import Data.Map.Strict (Map) import Data.Maybe (fromMaybe)@@ -122,6 +124,7 @@ import Quiet (Quiet (..)) import Control.Monad.IOSim.CommonTypes+import Control.Monad.IOSim.CommonTypes qualified as Sim import Control.Monad.IOSim.STM import Control.Monad.IOSimPOR.Types @@ -193,6 +196,7 @@ ExploreRaces :: SimA s b -> SimA s b Fix :: (x -> IOSim s x) -> (x -> SimA s r) -> SimA s r+ NewUnique :: (Sim.Unique s -> SimA s r) -> SimA s r newtype STM s a = STM { unSTM :: forall r. (a -> StmA s r) -> StmA s r }@@ -626,6 +630,11 @@ instance MonadLabelledMVar (IOSim s) where labelMVar = labelMVarDefault +instance MonadUnique (IOSim s) where+ type Unique (IOSim s) = Sim.Unique s+ newUnique = IOSim (oneShot NewUnique)+ hashUnique = hash+ data Async s a = Async !IOSimThreadId (STM s (Either SomeException a)) instance Eq (Async s a) where@@ -716,7 +725,8 @@ instance SI.MonadDelay (IOSim s) where threadDelay d =- IOSim $ oneShot $ \k -> ThreadDelay d (k ())+ IOSim $ oneShot $ \k -> ThreadDelay (SI.roundDiffTimeToMicroseconds d)+ (k ()) data Timeout s = Timeout !(TVar s TimeoutState) !TimeoutId -- ^ a timeout@@ -756,11 +766,15 @@ timeout d action | d < 0 = Just <$> action | d == 0 = return Nothing- | otherwise = IOSim $ oneShot $ \k -> StartTimeout d (runIOSim action) k+ | otherwise = IOSim $ oneShot $ \k ->+ StartTimeout (SI.roundDiffTimeToMicroseconds d)+ (runIOSim action)+ k - registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d k+ registerDelay d = IOSim $ oneShot $ \k ->+ RegisterDelay (SI.roundDiffTimeToMicroseconds d) k registerDelayCancellable d = do- t <- newTimeout d+ t <- newTimeout (SI.roundDiffTimeToMicroseconds d) return (readTimeout t, cancelTimeout t) newtype TimeoutException = TimeoutException TimeoutId deriving Eq@@ -1056,6 +1070,9 @@ | EventThreadUnhandled SomeException -- ^ thread terminated by an unhandled exception + | EventUniqueCreated Integer+ -- ^ created the n-th 'Unique'+ -- -- STM events --@@ -1163,6 +1180,7 @@ EventThreadFinished -> "ThreadFinished" EventThreadUnhandled a -> "ThreadUnhandled " ++ show a+ EventUniqueCreated n -> "UniqueCreated " ++ show n EventTxCommitted written created mbEff -> concat [ "TxCommitted ", ppList (ppLabelled show) written, " ",
src/Control/Monad/IOSimPOR/Internal.hs view
@@ -198,6 +198,7 @@ clocks :: !(Map ClockId UTCTime), nextVid :: !VarId, -- ^ next unused 'TVarId' nextTmid :: !TimeoutId, -- ^ next unused 'TimeoutId'+ nextUniq :: !(Unique s), -- ^ next unused @'Unique' s@ -- | previous steps (which we may race with). -- Note this is *lazy*, so that we don't compute races we will not reverse. races :: Races,@@ -220,6 +221,7 @@ clocks = Map.singleton (ClockId []) epoch1970, nextVid = 0, nextTmid = TimeoutId 0,+ nextUniq = MkUnique 0, races = noRaces, control = ControlDefault, control0 = ControlDefault,@@ -273,7 +275,7 @@ threads, timers, clocks,- nextVid, nextTmid,+ nextVid, nextTmid, nextUniq, curTime = time, control, perStepTimeLimit@@ -813,6 +815,13 @@ YieldSim k -> do let thread' = thread { threadControl = ThreadControl k ctl } schedule thread' simstate++ NewUnique k -> do+ let thread' = thread{ threadControl = ThreadControl (k nextUniq) ctl }+ n = unMkUnique nextUniq+ simstate' = simstate{ nextUniq = MkUnique (n + 1) }+ SimPORTrace time tid tstep tlbl (EventUniqueCreated n)+ <$> schedule thread' simstate' threadInterruptible :: Thread s a -> Bool
test/Test/Control/Monad/IOSim.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-}+-- `-fno-full-laziness` is needed for `discardAfter` to work correctly, see+-- `unit_discardAfter` below.+{-# OPTIONS_GHC -fno-full-laziness #-} module Test.Control.Monad.IOSim ( tests@@ -43,6 +46,7 @@ import Test.Control.Monad.Utils import Test.QuickCheck+import Test.QuickCheck.Property as QC import Test.Tasty hiding (after) import Test.Tasty.QuickCheck @@ -67,6 +71,10 @@ , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay , testProperty "throwTo and STM" unit_throwTo_and_stm ]+ , testGroup "QuickCheck"+ [ testProperty "timeout: discardAfter" unit_discardAfter+ , testProperty "timeout: within" unit_within+ ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) , testProperty "order (IO)" (expectFailure prop_fork_order_IO)@@ -1071,6 +1079,46 @@ | otherwise -- i.e. timeout0 >= timeout1 = Just Nothing+++-- | Check that `discardAfter` works as expected.+--+-- NOTE: using `discardAfter` with `IOSim` is more tricky than for `IO`+-- properties, since `IOSim` is a pure computation. One need to wrap the+-- simulation in a lambda and use `-fno-full-laziness` to avoid GHC from+-- moving the thunk outside of the lambda, and evaluating it just once.+--+unit_discardAfter :: Property+unit_discardAfter = mapTotalResult f+ . discardAfter 10+ $ \() -> runSimOrThrow $ True <$ (forever (threadDelay 10))+ where+ -- if `discard` kills the computation with the `Timeout` exception,+ -- `theException` is `Nothing`, but if `traceResult` wraps it, then it is+ -- a `Just`. We mark each test a success if `theException` is `Nothing`,+ -- otherwise the test would fail with too many discarded cases, but if we re+ -- introduce the bug in `traceResult` then it fails, since then+ -- `theException` is a `Just`.+ f :: QC.Result -> QC.Result+ f r@MkResult { QC.theException = Nothing }+ = r { ok = Just True }+ f r = r+++-- | Check that `within` works as expected.+--+unit_within :: Property+unit_within = mapTotalResult f+ . within 10+ $ runSimOrThrow $ True <$ (forever (threadDelay 10))+ where+ -- if `within` kills the computation with the `Timeout` exception,+ -- `theException` is `Nothing`, but if `traceResult` wraps it, then it is+ -- a `Just`.+ f :: QC.Result -> QC.Result+ f r@MkResult { QC.theException = Nothing }+ = r { expect = False }+ f r = r unit_timeouts_and_async_exceptions_1 :: Property