diff --git a/dejafu/CHANGELOG.markdown b/dejafu/CHANGELOG.markdown index 5720591..b066447 100644 --- a/dejafu/CHANGELOG.markdown +++ b/dejafu/CHANGELOG.markdown @@ -14,11 +14,15 @@ unreleased - 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`. + --------------------------------------------------------------------------------------------------- diff --git a/dejafu/Test/DejaFu/Common.hs b/dejafu/Test/DejaFu/Common.hs index 0e727dc..e80303c 100644 --- a/dejafu/Test/DejaFu/Common.hs +++ b/dejafu/Test/DejaFu/Common.hs @@ -267,7 +267,7 @@ initialIdSource = Id 0 0 0 0 [] [] [] [] -- | All the actions that a thread can perform. -- --- @since 0.5.0.2 +-- @since unreleased data ThreadAction = Fork ThreadId -- ^ Start a new thread. @@ -279,6 +279,8 @@ data ThreadAction = -- ^ 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] @@ -355,9 +357,9 @@ data ThreadAction = -- ^ 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 @@ -418,7 +420,7 @@ tvarsOf act = S.fromList $ case act of -- | A one-step look-ahead at what a thread will do next. -- --- @since 0.5.0.2 +-- @since unreleased data Lookahead = WillFork -- ^ Will start a new thread. @@ -432,6 +434,8 @@ data Lookahead = -- simultaneously. | WillYield -- ^ Will yield the current thread. + | WillThreadDelay Int + -- ^ Will yield/delay the current thread. | WillNewMVar -- ^ Will create a new 'MVar'. | WillPutMVar MVarId @@ -495,8 +499,8 @@ data Lookahead = -- ^ 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 @@ -526,6 +530,7 @@ rewind MyThreadId = Just WillMyThreadId 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) @@ -566,6 +571,7 @@ rewind StopSubconcurrency = Just WillStopSubconcurrency willRelease :: Lookahead -> Bool willRelease WillFork = True willRelease WillYield = True +willRelease (WillThreadDelay _) = True willRelease (WillPutMVar _) = True willRelease (WillTryPutMVar _) = True willRelease (WillReadMVar _) = True @@ -813,6 +819,7 @@ preEmpCount :: [(Decision, ThreadAction)] -> 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 @@ -820,6 +827,7 @@ preEmpCount (x:xs) (d, _) = go initialThread x xs where go tid _ (r@(Continue, _):rest) = go tid r rest go _ prior [] = case (prior, d) of ((_, Yield), SwitchTo _) -> 0 + ((_, ThreadDelay _), SwitchTo _) -> 0 (_, SwitchTo _) -> 1 _ -> 0 diff --git a/dejafu/Test/DejaFu/Conc.hs b/dejafu/Test/DejaFu/Conc.hs index 3031695..e0df7d3 100755 --- a/dejafu/Test/DejaFu/Conc.hs +++ b/dejafu/Test/DejaFu/Conc.hs @@ -137,6 +137,7 @@ instance Monad n => C.MonadConc (ConcT r n) where myThreadId = toConc AMyTId yield = toConc (\c -> AYield (c ())) + threadDelay n = toConc (\c -> ADelay n (c ())) -- ---------- diff --git a/dejafu/Test/DejaFu/Conc/Internal.hs b/dejafu/Test/DejaFu/Conc/Internal.hs index 8f6b831..3260ee5 100755 --- a/dejafu/Test/DejaFu/Conc/Internal.hs +++ b/dejafu/Test/DejaFu/Conc/Internal.hs @@ -192,6 +192,9 @@ stepThread sched memtype tid action ctx = case action of -- 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) diff --git a/dejafu/Test/DejaFu/Conc/Internal/Common.hs b/dejafu/Test/DejaFu/Conc/Internal/Common.hs index 04c6154..00997d4 100755 --- a/dejafu/Test/DejaFu/Conc/Internal/Common.hs +++ b/dejafu/Test/DejaFu/Conc/Internal/Common.hs @@ -141,6 +141,7 @@ data Action n r = | 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 (AMasking ms _ _) = WillSetMasking False ms 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/dejafu/Test/DejaFu/SCT.hs b/dejafu/Test/DejaFu/SCT.hs index ad3e207..0462a36 100755 --- a/dejafu/Test/DejaFu/SCT.hs +++ b/dejafu/Test/DejaFu/SCT.hs @@ -661,9 +661,9 @@ yieldCountInc sofar prior (d, lnext) = case prior of 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/dejafu/Test/DejaFu/SCT/Internal.hs b/dejafu/Test/DejaFu/SCT/Internal.hs index 87a9267..01cf917 100644 --- a/dejafu/Test/DejaFu/SCT/Internal.hs +++ b/dejafu/Test/DejaFu/SCT/Internal.hs @@ -799,11 +799,13 @@ initialDPORThread = S.elemAt 0 . dporRunnable -- | 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.