Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added support for grandchild threads.

  • Loading branch information...
commit c23e19cbe78cc6964f23fdb90b7029c5ae54dd35 1 parent f5da12c
@timthelion authored
View
35 Test/GrandChildTest.lhs
@@ -0,0 +1,35 @@
+What happens if I create a tree of threads like:
+
+ThreadMain
+ ChildThread
+ GrandChildThread
+
+And ChildThread ends? Normally GrandChildThread dies. This module tests whether ThreadManager successfully flattens this thread hierarchy to:
+
+ThreadMain
+ ChildThread
+ GrandChildThread
+
+thus saving GrandChildThread in the case of ChildThread's death.
+
+>import qualified Control.Concurrent.ThreadManager as TM
+>import Control.Concurrent
+
+>main :: IO ()
+>main = do
+> tm <- TM.make
+> TM.fork tm (childThread tm)
+> TM.waitForAll tm
+> print "If you see this message, your grandChild has died and you should morn like the poorest of poppers."
+
+
+>childThread :: TM.ThreadManager -> IO ()
+>childThread tm = do
+> TM.fork tm (grandChildThread 0)
+
+> return ()
+
+>grandChildThread :: Int -> IO ()
+>grandChildThread count =
+> print count >> threadDelay 1000 >> (grandChildThread $ count+1)
+
View
48 src/Control/Concurrent/ThreadManager.hs
@@ -26,16 +26,38 @@ data ThreadStatus =
| Threw SomeException
deriving Show
-newtype ThreadManager = TM (MVar (M.Map ThreadId (MVar ThreadStatus)))
+data ThreadManager = TM (MVar (M.Map ThreadId (MVar ThreadStatus))) (MVar (IO ()))
deriving Eq
--- | Make a thread manager.
+-- | Make a thread manager. This should be run in a thread that won't die.
make :: IO ThreadManager
-make = TM `fmap` newMVar M.empty
+make = do
+ print "hiii"
+ listenerMVar <- newEmptyMVar
+ mvarMaps <- newMVar M.empty
+ tm <- return $ TM mvarMaps listenerMVar
+ forkIO $ listen tm
+ return tm
+
+-- | This thread becomes the parent of all other threads.
+listen :: ThreadManager -> IO ()
+listen tm@(TM map listenerMVar) = do
+ command <- takeMVar listenerMVar
+ command
+ listen tm
+
+runCommand :: ThreadManager -> IO a -> IO a
+runCommand tm@(TM _ listenerMVar) command = do
+ resultMVar <- newEmptyMVar
+ putMVar listenerMVar (command >>= putMVar resultMVar)
+ takeMVar resultMVar
-- | Make a managed thread. Uses 'forkIO'.
fork :: ThreadManager -> IO () -> IO ThreadId
-fork (TM tm) action =
+fork tm action = runCommand tm (fork' tm action)
+
+fork' :: ThreadManager -> IO () -> IO ThreadId
+fork' (TM tm _) action =
modifyMVar tm $ \m -> do
state <- newEmptyMVar
tid <- forkIO $ do
@@ -45,11 +67,16 @@ fork (TM tm) action =
-- | Make the given number of managed threads.
forkn :: ThreadManager -> Int -> IO () -> IO [ThreadId]
-forkn tm n = replicateM n . fork tm
+forkn tm n action = runCommand tm (forkn' tm n action)
+
+forkn' :: ThreadManager -> Int -> IO () -> IO [ThreadId]
+forkn' tm n = replicateM n . fork tm
-- | Get the status of a managed thread.
getStatus :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
-getStatus (TM tm) tid =
+getStatus tm tid = runCommand tm $ getStatus' tm tid
+getStatus' :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
+getStatus' (TM tm _) tid =
modifyMVar tm $ \m ->
case M.lookup tid m of
Nothing -> return (m, Nothing)
@@ -61,7 +88,10 @@ getStatus (TM tm) tid =
-- | Block until a specific managed thread terminates.
waitFor :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
-waitFor (TM tm) tid =
+waitFor tm tid = runCommand tm $ waitFor' tm tid
+
+waitFor' :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)
+waitFor' (TM tm _) tid =
join . modifyMVar tm $ \m ->
return $
case M.updateLookupWithKey (\_ _ -> Nothing) tid m of
@@ -70,7 +100,9 @@ waitFor (TM tm) tid =
-- | Block until all managed threads terminate.
waitForAll :: ThreadManager -> IO ()
-waitForAll (TM tm) =
+waitForAll tm = runCommand tm $ waitForAll' tm
+waitForAll' :: ThreadManager -> IO ()
+waitForAll' (TM tm _) =
modifyMVar tm elems >>= mapM_ takeMVar
where
elems m = return (M.empty, M.elems m)
View
2  threadmanager.cabal
@@ -1,5 +1,5 @@
name: threadmanager
-version: 0.1.4
+version: 0.1.5
category: Concurrency
Please sign in to comment.
Something went wrong with that request. Please try again.