diff options
author | joe <joe@jerkface.net> | 2017-07-28 20:58:43 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-07-28 20:58:43 -0400 |
commit | d0ff6c3ac977035f3493b679978da73517550028 (patch) | |
tree | f00c62d6e95a7f10ff58580601c5651465310cc0 /src/Control/Concurrent/Lifted/Instrument.hs | |
parent | e4ecff0ba5ad4b392a419ab7723c5df49513d1fa (diff) |
More details in threads listing.
Diffstat (limited to 'src/Control/Concurrent/Lifted/Instrument.hs')
-rw-r--r-- | src/Control/Concurrent/Lifted/Instrument.hs | 13 |
1 files changed, 6 insertions, 7 deletions
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs index 957b67bb..7ee78c8b 100644 --- a/src/Control/Concurrent/Lifted/Instrument.hs +++ b/src/Control/Concurrent/Lifted/Instrument.hs | |||
@@ -45,26 +45,25 @@ fork action = do | |||
45 | t <- Raw.fork $ do | 45 | t <- Raw.fork $ do |
46 | tid <- myThreadId | 46 | tid <- myThreadId |
47 | tm <- liftBase getCurrentTime | 47 | tm <- liftBase getCurrentTime |
48 | bracket_ (modifyThreads $ Map.insert tid (PerThread "" tm)) | 48 | bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm)) |
49 | (modifyThreads $ Map.delete tid) | 49 | (modifyThreads $! Map.delete tid) |
50 | action | 50 | action |
51 | return t | 51 | return t |
52 | 52 | ||
53 | labelThread :: ThreadId -> String -> IO () | 53 | labelThread :: ThreadId -> String -> IO () |
54 | labelThread tid s = do | 54 | labelThread tid s = do |
55 | GHC.labelThread tid s | 55 | GHC.labelThread tid s |
56 | modifyThreads $ Map.adjust (\pt -> pt { lbl = s }) tid | 56 | modifyThreads $! Map.adjust (\pt -> pt { lbl = s }) tid |
57 | {-# INLINE labelThread #-} | 57 | {-# INLINE labelThread #-} |
58 | 58 | ||
59 | threadsInformation :: IO [PerThread] | 59 | threadsInformation :: IO [(ThreadId,PerThread)] |
60 | threadsInformation = do | 60 | threadsInformation = do |
61 | m <- threads <$> readMVar globals | 61 | m <- threads <$> readMVar globals |
62 | return $ Map.elems m | 62 | return $ Map.toList m |
63 | 63 | ||
64 | 64 | ||
65 | modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m () | 65 | modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m () |
66 | modifyThreads f = do | 66 | modifyThreads f = do |
67 | g <- takeMVar globals | 67 | g <- takeMVar globals |
68 | let f' st = st { threads = f (threads st) } | 68 | let f' st = st { threads = f (threads st) } |
69 | r = f' g | 69 | putMVar globals $! f' g |
70 | putMVar globals r | ||