From 0e0e49d2381738501139d311b3147c6ae8179e11 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 28 Nov 2019 21:25:01 -0500 Subject: This seems to be more stable. --- .../src/Control/Concurrent/Lifted/Instrument.hs | 33 ++++++++++++++-------- 1 file changed, 21 insertions(+), 12 deletions(-) (limited to 'lifted-concurrent') diff --git a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs index 070745b6..2c35419e 100644 --- a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs +++ b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs @@ -81,15 +81,22 @@ instrumented rawFork action = do $ do catch action $ \e -> case fromException e of Just ThreadKilled -> return () Nothing -> liftBase $ do - g <- takeMVar globals - let l = concat [ show e - , " (" - , maybe "" lbl $ Map.lookup tid (threads g) - , ")" - ] - reportException g l - putMVar globals $! g { threads = Map.insert tid (PerThread l tm) $ threads g } - throwIO e + bracket (takeMVar globals) + (\g -> do + let l = concat [ show e + , " (" + , maybe "" lbl $ Map.lookup tid (threads g) + , ")" + ] + putMVar globals $! g { threads = Map.insert tid (PerThread l tm) $ threads g } + throwIO e) + (\g -> do + let l = concat [ show e + , " (" + , maybe "" lbl $ Map.lookup tid (threads g) + , ")" + ] + reportException g l) -- Remove the thread only if it terminated normally or was killed. modifyThreads $! Map.delete tid return t @@ -106,8 +113,10 @@ threadsInformation = do return $ Map.toList m -modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m () +modifyThreads :: MonadBaseControl IO m => + (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m () modifyThreads f = do - g <- takeMVar globals let f' st = st { threads = f (threads st) } - putMVar globals $! f' g + bracket (takeMVar globals) + (\g -> putMVar globals $! f' g) + (\g -> return ()) -- cgit v1.2.3