Merge pull request #91 from kazu-yamamoto/manager

Improving the thread manager

Network/HTTP2/Arch/Manager.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE RankNTypes #-}
 
--- | A thread pool manager.
+-- | A thread manager.
 --   The manager has responsibility to spawn and kill
 --   worker threads.
 module Network.HTTP2.Arch.Manager (
@@ -12,10 +12,9 @@ module Network.HTTP2.Arch.Manager (
   , spawnAction
   , forkManaged
   , forkManagedUnmask
-  , deleteMyId
   , timeoutKillThread
   , timeoutClose
-  , KilledByHttp2ThreadPoolManager(..)
+  , KilledByHttp2ThreadManager(..)
   , incCounter
   , decCounter
   , waitCounter0
@@ -43,10 +42,10 @@ noAction = return ()
 
 data Command = Stop (Maybe SomeException) | Spawn | Add ThreadId | Delete ThreadId
 
--- | Manager to manage the thread pool and the timer.
+-- | Manager to manage the thread and the timer.
 data Manager = Manager (TQueue Command) (IORef Action) (TVar Int) T.Manager
 
--- | Starting a thread pool manager.
+-- | Starting a thread manager.
 --   Its action is initially set to 'return ()' and should be set
 --   by 'setAction'. This allows that the action can include
 --   the manager itself.
@@ -70,7 +69,9 @@ start timmgr = do
       where
         next tset = do
             action <- readIORef ref
-            newtid <- forkIO action
+            newtid <- forkFinally action $ \_ -> do
+                mytid <- myThreadId
+                atomically $ writeTQueue q $ Delete mytid
             let tset' = add newtid tset
             go q tset' ref
 
@@ -141,7 +142,7 @@ del tid set = set'
     set' = Set.delete tid set
 
 kill :: Set ThreadId -> Maybe SomeException -> IO ()
-kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadPoolManager err) set
+kill set err = traverse_ (\tid -> E.throwTo tid $ KilledByHttp2ThreadManager err) set
 
 -- | Killing the IO action of the second argument on timeout.
 timeoutKillThread :: Manager -> (T.Handle -> IO ()) -> IO ()
@@ -156,10 +157,10 @@ timeoutClose (Manager _ _ _ tmgr) closer = do
     th <- T.register tmgr closer
     return $ T.tickle th
 
-data KilledByHttp2ThreadPoolManager = KilledByHttp2ThreadPoolManager (Maybe SomeException)
+data KilledByHttp2ThreadManager = KilledByHttp2ThreadManager (Maybe SomeException)
   deriving Show
 
-instance Exception KilledByHttp2ThreadPoolManager where
+instance Exception KilledByHttp2ThreadManager where
   toException   = asyncExceptionToException
   fromException = asyncExceptionFromException
 

Network/HTTP2/Internal.hs

@@ -24,8 +24,8 @@ module Network.HTTP2.Internal (
   , defaultTrailersMaker
   , NextTrailersMaker(..)
   , runTrailersMaker
-  -- * Exceptions
-  , KilledByHttp2ThreadPoolManager(..)
+  -- * Thread Manager
+  , module Network.HTTP2.Arch.Manager
   ) where
 
 import Network.HTTP2.Arch.File

Network/HTTP2/Server/Worker.hs

@@ -144,10 +144,6 @@ response wc@WorkerConf{..} mgr th tconf strm (Request req) (Response rsp) pps =
           finished = atomically $ writeTBQueue tbq $ StreamingFinished (decCounter mgr)
       incCounter mgr
       strmbdy push flush `E.finally` finished
-      -- Remove the thread's ID from the manager's queue, to ensure the that the
-      -- manager will not terminate it before we are done. (The thread ID was
-      -- added implicitly when the worker was spawned by the manager).
-      deleteMyId mgr
   OutBodyStreamingUnmask _ ->
     error "response: server does not support OutBodyStreamingUnmask"
   where
@@ -175,7 +171,7 @@ worker wc@WorkerConf{..} mgr server = do
             Right () -> return True
             Left e@(SomeException _)
               -- killed by the local worker manager
-              | Just KilledByHttp2ThreadPoolManager{} <- E.fromException e -> return False
+              | Just KilledByHttp2ThreadManager{} <- E.fromException e -> return False
               -- killed by the local timeout manager
               | Just T.TimeoutThread <- E.fromException e -> do
                   cleanup sinfo