Add a ThreadAction for threadDelay

Closes #131

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`.
+
 
 ---------------------------------------------------------------------------------------------------
 

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
 

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 ()))
 
   -- ----------
 

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)

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

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

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.