Available ThreadIds. Closes #3

Control/Monad/Conc/Class.hs

@@ -8,11 +8,12 @@ module Control.Monad.Conc.Class where
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, readMVar, newEmptyMVar, putMVar, tryPutMVar, takeMVar, tryTakeMVar)
 import Control.Exception (Exception)
-import Control.Monad (unless, void)
+import Control.Monad (unless)
 import Control.Monad.Catch (MonadCatch, MonadThrow, catch, throwM)
 import Control.Monad.STM (STM)
 import Control.Monad.STM.Class (MonadSTM)
 
+import qualified Control.Concurrent as C
 import qualified Control.Monad.STM as S
 
 -- | @MonadConc@ is like a combination of 'ParFuture' and 'ParIVar'
@@ -38,7 +39,9 @@ import qualified Control.Monad.STM as S
 -- 'takeCVar' and 'putCVar', however, are very inefficient, and should
 -- probably always be overridden to make use of
 -- implementation-specific blocking functionality.
-class (Monad m, MonadCatch m, MonadSTM (STMLike m), MonadThrow m) => MonadConc m  where
+class ( Monad m, MonadCatch m, MonadThrow m
+      , MonadSTM (STMLike m)
+      , Eq (ThreadId m), Show (ThreadId m)) => MonadConc m  where
   -- | The associated 'MonadSTM' for this class.
   type STMLike m :: * -> *
 
@@ -48,21 +51,27 @@ class (Monad m, MonadCatch m, MonadSTM (STMLike m), MonadThrow m) => MonadConc m
   -- @CVar@ will block until it is empty.
   type CVar m :: * -> *
 
+  -- | An abstract handle to a thread
+  type ThreadId m :: *
+
   -- | Fork a computation to happen concurrently. Communication may
   -- happen over @CVar@s.
-  fork :: m () -> m ()
+  fork :: m () -> m (ThreadId m)
+
+  -- | Get the @ThreadId@ of the current thread.
+  myThreadId :: m (ThreadId m)
 
   -- | Create a concurrent computation for the provided action, and
   -- return a @CVar@ which can be used to query the result.
   --
   -- > spawn ma = do
   -- >   cvar <- newEmptyCVar
-  -- >   fork $ ma >>= putCVar cvar
+  -- >   _ <- fork $ ma >>= putCVar cvar
   -- >   return cvar
   spawn :: m a -> m (CVar m a)
   spawn ma = do
     cvar <- newEmptyCVar
-    fork $ ma >>= putCVar cvar
+    _ <- fork $ ma >>= putCVar cvar
     return cvar
 
   -- | Create a new empty @CVar@.
@@ -139,11 +148,13 @@ class (Monad m, MonadCatch m, MonadSTM (STMLike m), MonadThrow m) => MonadConc m
   _concNoTest = id
 
 instance MonadConc IO where
-  type STMLike IO = STM
-  type CVar    IO = MVar
+  type STMLike IO  = STM
+  type CVar    IO  = MVar
+  type ThreadId IO = C.ThreadId
 
   readCVar     = readMVar
-  fork         = void . forkIO
+  fork         = forkIO
+  myThreadId   = C.myThreadId
   newEmptyCVar = newEmptyMVar
   putCVar      = putMVar
   tryPutCVar   = tryPutMVar

Test/DejaFu/Deterministic.hs

@@ -14,6 +14,7 @@ module Test.DejaFu.Deterministic
   , Failure(..)
   , runConc
   , fork
+  , myThreadId
   , spawn
   , atomically
   , throw
@@ -68,10 +69,12 @@ instance Ca.MonadThrow (Conc t) where
   throwM = throw
 
 instance C.MonadConc (Conc t) where
-  type CVar    (Conc t) = CVar t
-  type STMLike (Conc t) = STMLike t (ST t) (STRef t)
+  type CVar     (Conc t) = CVar t
+  type STMLike  (Conc t) = STMLike t (ST t) (STRef t)
+  type ThreadId (Conc t) = Int
 
   fork         = fork
+  myThreadId   = myThreadId
   newEmptyCVar = newEmptyCVar
   putCVar      = putCVar
   tryPutCVar   = tryPutCVar
@@ -102,8 +105,12 @@ readCVar :: CVar t a -> Conc t a
 readCVar cvar = C $ cont $ AGet $ unV cvar
 
 -- | Run the provided computation concurrently.
-fork :: Conc t () -> Conc t ()
-fork (C ma) = C $ cont $ \c -> AFork (runCont ma $ const AStop) $ c ()
+fork :: Conc t () -> Conc t ThreadId
+fork (C ma) = C $ cont $ AFork (runCont ma $ const AStop)
+
+-- | Get the 'ThreadId' of the current thread.
+myThreadId :: Conc t ThreadId
+myThreadId = C $ cont AMyTId
 
 -- | Run the provided 'MonadSTM' transaction atomically. If 'retry' is
 -- called, it will be blocked until any of the touched 'CTVar's have

Test/DejaFu/Deterministic/IO.hs

@@ -18,6 +18,7 @@ module Test.DejaFu.Deterministic.IO
   , runConcIO
   , liftIO
   , fork
+  , myThreadId
   , spawn
   , atomically
   , throw
@@ -72,10 +73,12 @@ instance IO.MonadIO (ConcIO t) where
   liftIO = liftIO
 
 instance C.MonadConc (ConcIO t) where
-  type CVar    (ConcIO t) = CVar t
-  type STMLike (ConcIO t) = STMLike t IO IORef
+  type CVar     (ConcIO t) = CVar t
+  type STMLike  (ConcIO t) = STMLike t IO IORef
+  type ThreadId (ConcIO t) = Int
 
   fork         = fork
+  myThreadId   = myThreadId
   newEmptyCVar = newEmptyCVar
   putCVar      = putCVar
   tryPutCVar   = tryPutCVar
@@ -107,8 +110,12 @@ readCVar :: CVar t a -> ConcIO t a
 readCVar cvar = C $ cont $ AGet $ unV cvar
 
 -- | Run the provided computation concurrently.
-fork :: ConcIO t () -> ConcIO t ()
-fork (C ma) = C $ cont $ \c -> AFork (runCont ma $ const AStop) $ c ()
+fork :: ConcIO t () -> ConcIO t ThreadId
+fork (C ma) = C $ cont $ AFork (runCont ma $ const AStop)
+
+-- | Get the 'ThreadId' of the current thread.
+myThreadId :: ConcIO t ThreadId
+myThreadId = C $ cont AMyTId
 
 -- | Run the provided 'MonadSTM' transaction atomically. If 'retry' is
 -- called, it will be blocked until any of the touched 'CTVar's have

Test/DejaFu/Deterministic/Internal.hs

@@ -37,7 +37,8 @@ type Fixed n r s = Wrapper n r (Cont (Action n r s))
 -- primitives of the concurrency. 'spawn' is absent as it is
 -- implemented in terms of 'newEmptyCVar', 'fork', and 'putCVar'.
 data Action n r s =
-    AFork (Action n r s) (Action n r s)
+    AFork (Action n r s) (ThreadId -> Action n r s)
+  | AMyTId (ThreadId -> Action n r s)
   | forall a. APut     (R r a) a (Action n r s)
   | forall a. ATryPut  (R r a) a (Bool -> Action n r s)
   | forall a. AGet     (R r a) (a -> Action n r s)
@@ -105,6 +106,8 @@ instance NFData Decision where
 data ThreadAction =
     Fork ThreadId
   -- ^ Start a new thread.
+  | MyThreadId
+  -- ^ Get the 'ThreadId' of the current thread.
   | New CVarId
   -- ^ Create a new 'CVar'.
   | Put CVarId [ThreadId]
@@ -322,6 +325,7 @@ stepThread :: Monad n => Fixed n r s
            -> n (Either Failure (Threads n r s, IdSource, ThreadAction))
 stepThread fixed runconc runstm action idSource tid threads = case action of
   AFork    a b     -> stepFork    a b
+  AMyTId   c       -> stepMyTId c
   APut     ref a c -> stepPut     ref a c
   ATryPut  ref a c -> stepTryPut  ref a c
   AGet     ref c   -> stepGet     ref c
@@ -337,10 +341,13 @@ stepThread fixed runconc runstm action idSource tid threads = case action of
 
   where
     -- | Start a new thread, assigning it the next 'ThreadId'
-    stepFork a b = return $ Right (goto b tid threads', idSource', Fork newtid) where
+    stepFork a b = return $ Right (goto (b tid) tid threads', idSource', Fork newtid) where
       threads' = launch newtid a threads
       (idSource', newtid) = nextTId idSource
 
+    -- | Get the 'ThreadId' of the current thread
+    stepMyTId c = return $ Right (goto (c tid) tid threads, idSource, MyThreadId)
+
     -- | Put a value into a @CVar@, blocking the thread until it's
     -- empty.
     stepPut cvar@(cvid, _) a c = do