diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -7,6 +7,32 @@ *de facto* standard Haskell versioning scheme. +0.9.0.0 +------- + +- **Date** 2017-10-11 +- **Git tag** [dejafu-0.9.0.0][] +- **Hackage** https://hackage.haskell.org/package/dejafu-0.9.0.0 + +### Test.DejaFu.Common + +- New `isInternalError`, `isAbort`, `isDeadlock`, `isUncaughtException`, and + `isIllegalSubconcurrency` functions for matching failure types. Also exported from Test.DejaFu. + +- The `UncaughtException` `Failure` constructor now includes the exception. + + The `Read`, `Enum`, and `Bounded` instances are gone. The `Eq`, `Ord`, and `NFData` instances + use the `show` of the exception. Pretty-printed failures include the exception text. + +- New `ThreadDelay` and `WillThreadDelay` constructors in `ThreadAction` and `Lookahead`. Uses of + `threadDelay` are no longer reported as a use of `yield`. + +[dejafu-0.9.0.0]: https://github.com/barrucadu/dejafu/releases/tag/dejafu-0.9.0.0 + + +--------------------------------------------------------------------------------------------------- + + 0.8.0.0 ------- diff --git a/Test/DejaFu.hs b/Test/DejaFu.hs --- a/Test/DejaFu.hs +++ b/Test/DejaFu.hs @@ -251,6 +251,14 @@ , gives , gives' + -- ** Failures + + , isInternalError + , isAbort + , isDeadlock + , isUncaughtException + , isIllegalSubconcurrency + -- * Refinement property testing -- | Consider this statement about @MVar@s: \"using @readMVar@ is @@ -614,37 +622,37 @@ -- -- @since 0.1.0.0 deadlocksNever :: Predicate a -deadlocksNever = alwaysTrue (not . either (`elem` [Deadlock, STMDeadlock]) (const False)) +deadlocksNever = alwaysTrue (not . either isDeadlock (const False)) -- | Check that a computation always deadlocks. -- -- @since 0.1.0.0 deadlocksAlways :: Predicate a -deadlocksAlways = alwaysTrue $ either (`elem` [Deadlock, STMDeadlock]) (const False) +deadlocksAlways = alwaysTrue $ either isDeadlock (const False) -- | Check that a computation deadlocks at least once. -- -- @since 0.1.0.0 deadlocksSometimes :: Predicate a -deadlocksSometimes = somewhereTrue $ either (`elem` [Deadlock, STMDeadlock]) (const False) +deadlocksSometimes = somewhereTrue $ either isDeadlock (const False) -- | Check that a computation never fails with an uncaught exception. -- -- @since 0.1.0.0 exceptionsNever :: Predicate a -exceptionsNever = alwaysTrue (not . either (==UncaughtException) (const False)) +exceptionsNever = alwaysTrue (not . either isUncaughtException (const False)) -- | Check that a computation always fails with an uncaught exception. -- -- @since 0.1.0.0 exceptionsAlways :: Predicate a -exceptionsAlways = alwaysTrue $ either (==UncaughtException) (const False) +exceptionsAlways = alwaysTrue $ either isUncaughtException (const False) -- | Check that a computation fails with an uncaught exception at least once. -- -- @since 0.1.0.0 exceptionsSometimes :: Predicate a -exceptionsSometimes = somewhereTrue $ either (==UncaughtException) (const False) +exceptionsSometimes = somewhereTrue $ either isUncaughtException (const False) -- | Check that the result of a computation is always the same. In -- particular this means either: (a) it always fails in the same way, diff --git a/Test/DejaFu/Common.hs b/Test/DejaFu/Common.hs --- a/Test/DejaFu/Common.hs +++ b/Test/DejaFu/Common.hs @@ -53,6 +53,11 @@ -- * Failures , Failure(..) + , isInternalError + , isAbort + , isDeadlock + , isUncaughtException + , isIllegalSubconcurrency , showFail -- * Memory models @@ -64,8 +69,10 @@ ) where import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception(..), MaskingState(..)) +import Control.Exception (Exception(..), MaskingState(..), + SomeException, displayException) import Control.Monad.Ref (MonadRef(..)) +import Data.Function (on) import Data.List (intercalate) import Data.Maybe (fromMaybe, mapMaybe) import Data.Set (Set) @@ -260,7 +267,7 @@ -- | All the actions that a thread can perform. -- --- @since 0.5.0.2 +-- @since 0.9.0.0 data ThreadAction = Fork ThreadId -- ^ Start a new thread. @@ -272,6 +279,8 @@ -- ^ Set the number of Haskell threads that can run simultaneously. | Yield -- ^ Yield the current thread. + | ThreadDelay Int + -- ^ Yield/delay the current thread. | NewMVar MVarId -- ^ Create a new 'MVar'. | PutMVar MVarId [ThreadId] @@ -348,9 +357,9 @@ -- ^ Stop executing an action with @subconcurrency@. deriving (Eq, Show) --- | @since 0.5.1.0 instance NFData ThreadAction where rnf (Fork t) = rnf t + rnf (ThreadDelay n) = rnf n rnf (GetNumCapabilities c) = rnf c rnf (SetNumCapabilities c) = rnf c rnf (NewMVar m) = rnf m @@ -411,7 +420,7 @@ -- | A one-step look-ahead at what a thread will do next. -- --- @since 0.5.0.2 +-- @since 0.9.0.0 data Lookahead = WillFork -- ^ Will start a new thread. @@ -425,6 +434,8 @@ -- simultaneously. | WillYield -- ^ Will yield the current thread. + | WillThreadDelay Int + -- ^ Will yield/delay the current thread. | WillNewMVar -- ^ Will create a new 'MVar'. | WillPutMVar MVarId @@ -488,8 +499,8 @@ -- ^ Will stop executing an extion with @subconcurrency@. deriving (Eq, Show) --- | @since 0.5.1.0 instance NFData Lookahead where + rnf (WillThreadDelay n) = rnf n rnf (WillSetNumCapabilities c) = rnf c rnf (WillPutMVar m) = rnf m rnf (WillTryPutMVar m) = rnf m @@ -519,6 +530,7 @@ rewind (GetNumCapabilities _) = Just WillGetNumCapabilities rewind (SetNumCapabilities i) = Just (WillSetNumCapabilities i) rewind Yield = Just WillYield +rewind (ThreadDelay n) = Just (WillThreadDelay n) rewind (NewMVar _) = Just WillNewMVar rewind (PutMVar c _) = Just (WillPutMVar c) rewind (BlockedPutMVar c) = Just (WillPutMVar c) @@ -559,6 +571,7 @@ willRelease :: Lookahead -> Bool willRelease WillFork = True willRelease WillYield = True +willRelease (WillThreadDelay _) = True willRelease (WillPutMVar _) = True willRelease (WillTryPutMVar _) = True willRelease (WillReadMVar _) = True @@ -806,6 +819,7 @@ -> Int preEmpCount (x:xs) (d, _) = go initialThread x xs where go _ (_, Yield) (r@(SwitchTo t, _):rest) = go t r rest + go _ (_, ThreadDelay _) (r@(SwitchTo t, _):rest) = go t r rest go tid prior (r@(SwitchTo t, _):rest) | isCommitThread t = go tid prior (skip rest) | otherwise = 1 + go t r rest @@ -813,6 +827,7 @@ go tid _ (r@(Continue, _):rest) = go tid r rest go _ prior [] = case (prior, d) of ((_, Yield), SwitchTo _) -> 0 + ((_, ThreadDelay _), SwitchTo _) -> 0 (_, SwitchTo _) -> 1 _ -> 0 @@ -831,9 +846,12 @@ -- | An indication of how a concurrent computation failed. -- --- @since 0.5.0.0 -data Failure = - InternalError +-- The @Eq@, @Ord@, and @NFData@ instances compare/evaluate the +-- exception with @show@ in the @UncaughtException@ case. +-- +-- @since 0.9.0.0 +data Failure + = InternalError -- ^ Will be raised if the scheduler does something bad. This should -- never arise unless you write your own, faulty, scheduler! If it -- does, please file a bug report. @@ -846,17 +864,32 @@ -- ^ The computation became blocked indefinitely on @MVar@s. | STMDeadlock -- ^ The computation became blocked indefinitely on @TVar@s. - | UncaughtException + | UncaughtException SomeException -- ^ An uncaught exception bubbled to the top of the computation. | IllegalSubconcurrency -- ^ Calls to @subconcurrency@ were nested, or attempted when -- multiple threads existed. - deriving (Eq, Show, Read, Ord, Enum, Bounded) + deriving Show --- | @since 0.5.1.0 +instance Eq Failure where + (==) = (==) `on` _other + +instance Ord Failure where + compare = compare `on` _other + instance NFData Failure where - rnf f = f `seq` () + rnf = rnf . _other +-- | Convert failures into a different representation we can Eq / Ord +-- / NFData. +_other :: Failure -> (Int, Maybe String) +_other InternalError = (0, Nothing) +_other Abort = (1, Nothing) +_other Deadlock = (2, Nothing) +_other STMDeadlock = (3, Nothing) +_other (UncaughtException e) = (4, Just (show e)) +_other IllegalSubconcurrency = (5, Nothing) + -- | Pretty-print a failure -- -- @since 0.4.0.0 @@ -865,8 +898,44 @@ showFail Deadlock = "[deadlock]" showFail STMDeadlock = "[stm-deadlock]" showFail InternalError = "[internal-error]" -showFail UncaughtException = "[exception]" +showFail (UncaughtException exc) = "[" ++ displayException exc ++ "]" showFail IllegalSubconcurrency = "[illegal-subconcurrency]" + +-- | Check if a failure is an @InternalError@. +-- +-- @since undefined +isInternalError :: Failure -> Bool +isInternalError InternalError = True +isInternalError _ = False + +-- | Check if a failure is an @Abort@. +-- +-- @since undefined +isAbort :: Failure -> Bool +isAbort Abort = True +isAbort _ = False + +-- | Check if a failure is a @Deadlock@ or an @STMDeadlock@. +-- +-- @since undefined +isDeadlock :: Failure -> Bool +isDeadlock Deadlock = True +isDeadlock STMDeadlock = True +isDeadlock _ = False + +-- | Check if a failure is an @UncaughtException@ +-- +-- @since undefined +isUncaughtException :: Failure -> Bool +isUncaughtException (UncaughtException _) = True +isUncaughtException _ = False + +-- | Check if a failure is an @IllegalSubconcurrency@ +-- +-- @since undefined +isIllegalSubconcurrency :: Failure -> Bool +isIllegalSubconcurrency IllegalSubconcurrency = True +isIllegalSubconcurrency _ = False ------------------------------------------------------------------------------- -- Memory Models diff --git a/Test/DejaFu/Conc.hs b/Test/DejaFu/Conc.hs --- a/Test/DejaFu/Conc.hs +++ b/Test/DejaFu/Conc.hs @@ -137,6 +137,7 @@ myThreadId = toConc AMyTId yield = toConc (\c -> AYield (c ())) + threadDelay n = toConc (\c -> ADelay n (c ())) -- ---------- diff --git a/Test/DejaFu/Conc/Internal.hs b/Test/DejaFu/Conc/Internal.hs --- a/Test/DejaFu/Conc/Internal.hs +++ b/Test/DejaFu/Conc/Internal.hs @@ -192,6 +192,9 @@ -- yield the current thread AYield c -> simple (goto c tid (cThreads ctx)) Yield + -- yield the current thread (delay is ignored) + ADelay n c -> simple (goto c tid (cThreads ctx)) (ThreadDelay n) + -- create a new @MVar@, using the next 'MVarId'. ANewMVar n c -> do let (idSource', newmvid) = nextMVId n (cIdSource ctx) @@ -387,11 +390,12 @@ -- this is not inline in the long @case@ above as it's needed by -- @AAtom@, @AThrow@, and @AThrowTo@. stepThrow t ts act e = - case propagate (toException e) t ts of - Just ts' -> simple ts' act - Nothing - | t == initialThread -> pure (Left UncaughtException, Single act) - | otherwise -> simple (kill t ts) act + let some = toException e + in case propagate some t ts of + Just ts' -> simple ts' act + Nothing + | t == initialThread -> pure (Left (UncaughtException some), Single act) + | otherwise -> simple (kill t ts) act -- helper for actions which only change the threads. simple threads' act = pure (Right ctx { cThreads = threads' }, Single act) diff --git a/Test/DejaFu/Conc/Internal/Common.hs b/Test/DejaFu/Conc/Internal/Common.hs --- a/Test/DejaFu/Conc/Internal/Common.hs +++ b/Test/DejaFu/Conc/Internal/Common.hs @@ -141,6 +141,7 @@ | forall a. AAtom (STMLike n r a) (a -> Action n r) | ALift (n (Action n r)) | AYield (Action n r) + | ADelay Int (Action n r) | AReturn (Action n r) | ACommit ThreadId CRefId | AStop (n ()) @@ -181,6 +182,7 @@ lookahead (AResetMask b1 b2 ms _) = (if b1 then WillSetMasking else WillResetMasking) b2 ms lookahead (ALift _) = WillLiftIO lookahead (AYield _) = WillYield +lookahead (ADelay n _) = WillThreadDelay n lookahead (AReturn _) = WillReturn lookahead (AStop _) = WillStop lookahead (ASub _ _) = WillSubconcurrency diff --git a/Test/DejaFu/SCT.hs b/Test/DejaFu/SCT.hs --- a/Test/DejaFu/SCT.hs +++ b/Test/DejaFu/SCT.hs @@ -661,9 +661,9 @@ Just (tid, _) -> ycount (tidOf tid d) Nothing -> ycount initialThread where - ycount tnext = case lnext of - WillYield -> M.alter (Just . maybe 1 (+1)) tnext sofar - _ -> M.alter (Just . fromMaybe 0) tnext sofar + ycount tnext + | willYield lnext = M.alter (Just . maybe 1 (+1)) tnext sofar + | otherwise = M.alter (Just . fromMaybe 0) tnext sofar -- | Determine if an action is a commit or not. isCommitRef :: ThreadAction -> Bool diff --git a/Test/DejaFu/SCT/Internal.hs b/Test/DejaFu/SCT/Internal.hs --- a/Test/DejaFu/SCT/Internal.hs +++ b/Test/DejaFu/SCT/Internal.hs @@ -799,11 +799,13 @@ -- | Check if a thread yielded. didYield :: ThreadAction -> Bool didYield Yield = True +didYield (ThreadDelay _) = True didYield _ = False -- | Check if a thread will yield. willYield :: Lookahead -> Bool willYield WillYield = True +willYield (WillThreadDelay _) = True willYield _ = False -- | Check if an action will kill daemon threads. diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Systematic testing for Haskell concurrency. description: @@ -37,7 +37,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-0.8.0.0 + tag: dejafu-0.9.0.0 library exposed-modules: Test.DejaFu