Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix leak in H2 manager #155

Closed
wants to merge 1 commit into from
+38 −12
Closed

Fix leak in H2 manager #155

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
50 changes: 38 additions & 12 deletions Network/HTTP2/H2/Manager.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ import Control.Concurrent.STM
import Control.Exception
import qualified Control.Exception as E
import Data.Foldable
import Data.Map (Map)
import Data.Map.Strict (Map)
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I know this change doesn't do anything, it's just for clarity.

import qualified Data.Map.Strict as Map
import qualified System.TimeManager as T

Expand All @@ -28,9 +28,14 @@ import Imports
----------------------------------------------------------------

-- | Manager to manage the thread and the timer.
data Manager = Manager T.Manager (TVar ManagedThreads)
data Manager = Manager T.Manager ManagedThreads

type ManagedThreads = Map ThreadId TimeoutHandle
-- | The set of managed threads
--
-- This is a newtype to ensure that this is always updated strictly.
newtype ManagedThreads = WrapManagedThreads
{ unwrapManagedThreads :: TVar (Map ThreadId TimeoutHandle)
}

----------------------------------------------------------------

Expand All @@ -49,7 +54,7 @@ cancelTimeout ThreadWithoutTimeout = return ()
-- by 'setAction'. This allows that the action can include
-- the manager itself.
start :: T.Manager -> IO Manager
start timmgr = Manager timmgr <$> newTVarIO Map.empty
start timmgr = Manager timmgr <$> newManagedThreads

----------------------------------------------------------------

Expand All @@ -70,10 +75,7 @@ stopAfter :: Manager -> IO a -> (Maybe SomeException -> IO ()) -> IO a
stopAfter (Manager _timmgr var) action cleanup = do
mask $ \unmask -> do
ma <- try $ unmask action
m <- atomically $ do
m0 <- readTVar var
writeTVar var Map.empty
return m0
m <- atomically $ modifyManagedThreads var (\ts -> (Map.empty, ts))
forM_ (Map.elems m) cancelTimeout
let er = either Just (const Nothing) ma
forM_ (Map.keys m) $ \tid ->
Expand Down Expand Up @@ -102,17 +104,17 @@ forkManagedUnmask (Manager _timmgr var) label io =
void $ mask_ $ forkIOWithUnmask $ \unmask -> E.handle ignore $ do
labelMe label
tid <- myThreadId
atomically $ modifyTVar var $ Map.insert tid ThreadWithoutTimeout
atomically $ modifyManagedThreads_ var $ Map.insert tid ThreadWithoutTimeout
-- We catch the exception and do not rethrow it: we don't want the
-- exception printed to stderr.
io unmask `catch` ignore
atomically $ modifyTVar var $ Map.delete tid
atomically $ modifyManagedThreads_ var $ Map.delete tid
where
ignore (E.SomeException _) = return ()

waitCounter0 :: Manager -> IO ()
waitCounter0 (Manager _timmgr var) = atomically $ do
m <- readTVar var
m <- getManagedThreads var
check (Map.size m == 0)

----------------------------------------------------------------
Expand All @@ -122,5 +124,29 @@ withTimeout (Manager timmgr var) action =
T.withHandleKillThread timmgr (return ()) $ \th -> do
tid <- myThreadId
-- overriding ThreadWithoutTimeout
atomically $ modifyTVar var $ Map.insert tid $ ThreadWithTimeout th
atomically $ modifyManagedThreads_ var $ Map.insert tid $ ThreadWithTimeout th
action th

----------------------------------------------------------------

newManagedThreads :: IO ManagedThreads
newManagedThreads = WrapManagedThreads <$> newTVarIO Map.empty

getManagedThreads :: ManagedThreads -> STM (Map ThreadId TimeoutHandle)
getManagedThreads = readTVar . unwrapManagedThreads

modifyManagedThreads
:: ManagedThreads
-> (Map ThreadId TimeoutHandle -> (Map ThreadId TimeoutHandle, a))
-> STM a
modifyManagedThreads (WrapManagedThreads var) f = do
threads <- readTVar var
let (threads', result) = f threads
writeTVar var $! threads' -- strict update
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is the critical line.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm confused.
If this is critical, Data.Map.Strict is good enough.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No, that is not correct. Without the $!, it doesn't matter which function we use, because it is never called! It will just be a thunk build up of insert .. delete .. insert .. delete .. insert ... That's why it's critical to force the map to WHNF (not NF), so that we actually call the function we use.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We are using Strict and StrictData but threads' is in a tuple.
That's why?

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The improve-manager branch now use modifyTVar'.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No, that is not the reason. Strict does not make function application strict, it only makes bindings strict. So if we have a module in which Strict is not enabled (standing in for writeTVar)

module A where

ignore :: a -> String
ignore _ = "Hi"

then in

{-# LANGUAGE Strict, StrictData #-}

module B where

import A

ex1, ex2, ex3 :: IO ()
ex1 = putStrLn (ignore undefined)
ex2 = putStrLn (ignore $! undefined)
ex3 = let x = undefined in putStrLn (ignore x)

ex1 prints "Hi" whereas ex2 and ex3 both throw an exception.

return result

modifyManagedThreads_
:: ManagedThreads
-> (Map ThreadId TimeoutHandle -> Map ThreadId TimeoutHandle)
-> STM ()
modifyManagedThreads_ var f = modifyManagedThreads var (\ts -> (f ts, ()))
Loading