From 71db760db0291f8df7a7fa854a7a315e59556f71 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Wed, 25 Jan 2017 20:05:42 -0500
Subject: Fixed leak in thread instrumentation.

---
 src/Control/Concurrent/Lifted/Instrument.hs | 25 ++++++++-----------------
 1 file changed, 8 insertions(+), 17 deletions(-)

(limited to 'src/Control')

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
-- 
cgit v1.2.3