Fixed leak in thread instrumentation.

1 files changed, 8 insertions, 17 deletions

diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index e5ed9d5e..673e77cd 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -13,31 +13,26 @@ import Control.Concurrent.Lifted hiding (fork)
 import Control.Monad.Trans.Control
 import System.IO.Unsafe
 import System.Mem.Weak
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
+import qualified Data.Map.Strict  as Map
 import Control.Exception.Lifted
 import Control.Monad.Base
--- import Control.Monad.IO.Class
 import qualified GHC.Conc as GHC
 import Data.Time()
 import Data.Time.Clock
 
 data PerThread = PerThread
- { -- wkid :: Weak ThreadId
-   lbl :: String
- , startTime :: UTCTime
+ { lbl :: !String
+ , startTime :: !UTCTime
  }
- deriving (Eq,Ord,Show) -- ,Data,Generic)
+ deriving (Eq,Ord,Show)
 
 data GlobalState = GlobalState
- { threads :: Map.Map ThreadId PerThread -- IntMap.IntMap PerThread
- -- , uniqSource :: Int
+ { threads :: ! ( Map.Map ThreadId PerThread )
  }
 
 globals :: MVar GlobalState
 globals = unsafePerformIO $ newMVar $ GlobalState
     { threads = Map.empty
-    -- , uniqSource = 0
     }
 {-# NOINLINE globals #-}
 
@@ -48,8 +43,6 @@ forkIO = fork
 fork :: MonadBaseControl IO m => m () -> m ThreadId
 fork action = do
     t <- Raw.fork $ do
-        -- wkid <- myThreadId >>= liftBase . mkWeakThreadId
-        -- tid <- newUniq
         tid <- myThreadId
         tm <- liftBase getCurrentTime
         bracket_ (modifyThreads $ Map.insert tid (PerThread "" tm))
@@ -68,12 +61,10 @@ threadsInformation = do
     m <- threads <$> readMVar globals
     return $ Map.elems m
 
--- newUniq :: MonadBaseControl IO m => m Int
--- newUniq = do
---     modifyMVar globals (\st -> return (st { uniqSource = succ (uniqSource st) }, uniqSource st))
- 
+
 modifyThreads :: MonadBase 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)
+        r = f' g
+    threads r `seq` putMVar globals r