diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revsion history of io-sim +## 1.4.1.0 + +### Non-breaking changes + +* QuickCheck monadic combinators: `monadicIOSim`, `monadicIOSim_` and `runIOSimGen` (#140). +* New dependency on `primitive` +* Provides an instance for `PrimMonad`, giving access to most functionality + from the `primitive` package (#141). +* Prevented STM waking up threads blocked on `threadDelay` (#142). + ## 1.4.0.0 ### Breaking changes diff --git a/io-sim.cabal b/io-sim.cabal --- a/io-sim.cabal +++ b/io-sim.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: io-sim -version: 1.4.0.0 +version: 1.4.1.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurency (base & async style), stm, @@ -76,11 +76,12 @@ ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.20, - io-classes >=1.3 && <1.5, + io-classes ^>=1.4.1, exceptions >=0.10, containers, deepseq, nothunks, + primitive >=0.7 && <0.10, psqueues >=0.2 && <0.3, strict-stm ^>=1.4, si-timers ^>=1.4, 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 @@ -1,10 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -20,6 +21,10 @@ , Failure (..) , runSimTrace , runSimTraceST + -- *** QuickCheck Monadic combinators + , monadicIOSim_ + , monadicIOSim + , runIOSimGen -- ** Explore races using /IOSimPOR/ -- $iosimpor , exploreSimTrace @@ -119,6 +124,8 @@ import Control.Monad.IOSimPOR.QuickCheckUtils import Test.QuickCheck +import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) +import Test.QuickCheck.Monadic (PropertyM, monadic') import Debug.Trace qualified as Debug import System.IO.Unsafe @@ -751,3 +758,75 @@ Nothing -> error "compareTraceST: invariant violation" wakeup _ _ SimTrace {} = error "compareTracesST: invariant violation" wakeup _ _ fail = return fail + +-- +-- QuickCheck monadic combinators +-- + + + +-- | Like . +-- +-- Note: it calls `traceResult` in non-strict mode, e.g. leaked threads do not +-- cause failures. +-- +-- @since 1.4.1.0 +-- +monadicIOSim_ :: Testable a + => (forall s. PropertyM (IOSim s) a) + -> Property +monadicIOSim_ sim = + monadicIOSim + (\e -> case traceResult False e of + Left e -> counterexample (show e) False + Right p -> p) + id + sim + +-- | A more general version of `monadicIOSim_`, which: +-- +-- * allows to run in monad stacks build on top of `IOSim`; +-- * gives more control how to attach debugging information to failed +-- tests. +-- +-- Note, to use this combinator your monad needs to be defined as: +-- +-- > newtype M s a = M s { runM :: ReaderT State (IOSim s) a } +-- +-- It's important that `M s` is a monad. For such a monad one you'll need provide +-- a natural transformation: +-- @ +-- -- the state could also be created as an `IOSim` computation. +-- nat :: forall s a. State -> M s a -> 'IOSim' s a +-- nat state m = runStateT (runM m) state +-- @ +-- +-- @since 1.4.1.0 +-- +monadicIOSim :: (Testable a, forall s. Monad (m s)) + => (SimTrace Property -> Property) + -- ^ Allows to trace `SimTrace` in counterexamples. The simplest + -- use case is to pass: + -- + -- > either (\e -> counterexample (show e) False) id . traceResult False + -- + -- as `monadicIOSim_` does. + -- + -> (forall s a. m s a -> IOSim s a) + -- ^ natural transformation from `m` to @IOSim` s@ + -> (forall s. PropertyM (m s) a) + -> Property +monadicIOSim f tr sim = property (runIOSimGen f (tr <$> monadic' sim)) + +-- | Like . +-- +-- @since 1.4.1.0 +-- +runIOSimGen :: (SimTrace a -> Property) + -> (forall s. Gen (IOSim s a)) + -> Gen Property +runIOSimGen f sim = do + Capture eval <- capture + let trace = runSimTrace (eval sim) + return (f trace) diff --git a/src/Control/Monad/IOSim/Internal.hs b/src/Control/Monad/IOSim/Internal.hs --- a/src/Control/Monad/IOSim/Internal.hs +++ b/src/Control/Monad/IOSim/Internal.hs @@ -747,8 +747,10 @@ -- Check all fired threadDelays let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ] - wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM - (_, !simstate') = unblockThreads False wakeup simstate + !simstate' = + snd . unblockThreads False (fst `fmap` wakeupThreadDelay) + . snd . unblockThreads True wakeupSTM + $ simstate -- For each 'timeout' action where the timeout has fired, start a -- new thread to execute throwTo to interrupt the action. 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 @@ -102,6 +102,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.Primitive qualified as Prim import Control.Monad.ST.Lazy import Control.Monad.ST.Strict qualified as StrictST import Control.Monad.ST.Unsafe (unsafeSTToIO) @@ -633,7 +634,17 @@ asyncWithUnmask k = async (k unblock) asyncOnWithUnmask _ k = async (k unblock) +-- | This provides access to (almost) everything from the +-- @primitive@ package, but don't try to use the @MVar@s as that will not +-- work as expected. +-- +-- @since 1.4.1.0 +instance Prim.PrimMonad (IOSim s) where + type PrimState (IOSim s) = s + primitive st = IOSim $ oneShot $ \k -> LiftST (Prim.primitive st) k + instance MonadST (IOSim s) where + stToIO f = IOSim $ oneShot $ \k -> LiftST f k withLiftST f = f liftST -- | Lift an 'StrictST.ST' computation to 'IOSim'. diff --git a/src/Control/Monad/IOSimPOR/Internal.hs b/src/Control/Monad/IOSimPOR/Internal.hs --- a/src/Control/Monad/IOSimPOR/Internal.hs +++ b/src/Control/Monad/IOSimPOR/Internal.hs @@ -1033,9 +1033,11 @@ mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ] - wakeup = fst `fmap` wakeupThreadDelay ++ wakeupSTM -- TODO: the vector clock below cannot be right, can it? - (_, !simstate') = unblockThreads False bottomVClock wakeup simstate + !simstate' = + snd . unblockThreads False bottomVClock (fst `fmap` wakeupThreadDelay) + . snd . unblockThreads True bottomVClock wakeupSTM + $ simstate -- For each 'timeout' action where the timeout has fired, start a -- new thread to execute throwTo to interrupt the action. diff --git a/test/Test/Control/Monad/IOSim.hs b/test/Test/Control/Monad/IOSim.hs --- a/test/Test/Control/Monad/IOSim.hs +++ b/test/Test/Control/Monad/IOSim.hs @@ -68,6 +68,7 @@ , testProperty "async exceptions 2" unit_timeouts_and_async_exceptions_2 , testProperty "async exceptions 3" unit_timeouts_and_async_exceptions_3 , testProperty "threadDelay and STM" unit_threadDelay_and_stm + , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay , testProperty "throwTo and STM" unit_throwTo_and_stm ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) @@ -1159,6 +1160,34 @@ return (t1 `diffTime` t0 === delay) +unit_registerDelay_threadDelay :: Property +unit_registerDelay_threadDelay = + let trace = runSimTrace experiment in + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + v0 <- registerDelay 2 + v1 <- newTVarIO False + + _ <- forkIO $ do + threadDelay 1 + atomically $ writeTVar v1 True + + atomically $ do + b0 <- LazySTM.readTVar v0 + b1 <- readTVar v1 + check $ b0 || b1 + + let delay = 2 + t0 <- getMonotonicTime + threadDelay delay + t1 <- getMonotonicTime + + return (t1 `diffTime` t0 === delay) -- | Verify that a thread blocked on `throwTo` is not unblocked by an STM -- transaction. diff --git a/test/Test/Control/Monad/IOSimPOR.hs b/test/Test/Control/Monad/IOSimPOR.hs --- a/test/Test/Control/Monad/IOSimPOR.hs +++ b/test/Test/Control/Monad/IOSimPOR.hs @@ -70,6 +70,7 @@ , testProperty "timeout" prop_timeout , testProperty "timeouts" prop_timeouts , testProperty "stacked timeouts" prop_stacked_timeouts + , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) @@ -969,6 +970,35 @@ | otherwise -- i.e. timeout0 >= timeout1 = Just Nothing + +unit_registerDelay_threadDelay :: Property +unit_registerDelay_threadDelay = + exploreSimTrace id experiment $ \_ trace -> + counterexample (ppTrace_ trace) + . either (\e -> counterexample (show e) False) id + . traceResult False + $ trace + where + experiment :: IOSim s Property + experiment = do + v0 <- registerDelay 2 + v1 <- newTVarIO False + + _ <- forkIO $ do + threadDelay 1 + atomically $ writeTVar v1 True + + atomically $ do + b0 <- readTVar v0 + b1 <- readTVar v1 + check $ b0 || b1 + + let delay = 2 + t0 <- getMonotonicTime + threadDelay delay + t1 <- getMonotonicTime + + return (t1 `diffTime` t0 === delay) unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 =