blob: 673e77cd072de910514ed420a4f5c102737301f7 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
|
{-# LANGUAGE FlexibleContexts #-}
module Control.Concurrent.Lifted.Instrument
( module Control.Concurrent.Lifted
, forkIO
, fork
, labelThread
, threadsInformation
, PerThread(..)
) where
import qualified Control.Concurrent.Lifted as Raw
import Control.Concurrent.Lifted hiding (fork)
import Control.Monad.Trans.Control
import System.IO.Unsafe
import System.Mem.Weak
import qualified Data.Map.Strict as Map
import Control.Exception.Lifted
import Control.Monad.Base
import qualified GHC.Conc as GHC
import Data.Time()
import Data.Time.Clock
data PerThread = PerThread
{ lbl :: !String
, startTime :: !UTCTime
}
deriving (Eq,Ord,Show)
data GlobalState = GlobalState
{ threads :: ! ( Map.Map ThreadId PerThread )
}
globals :: MVar GlobalState
globals = unsafePerformIO $ newMVar $ GlobalState
{ threads = Map.empty
}
{-# NOINLINE globals #-}
forkIO :: IO () -> IO ThreadId
forkIO = fork
fork :: MonadBaseControl IO m => m () -> m ThreadId
fork action = do
t <- Raw.fork $ do
tid <- myThreadId
tm <- liftBase getCurrentTime
bracket_ (modifyThreads $ Map.insert tid (PerThread "" tm))
(modifyThreads $ Map.delete tid)
action
return t
labelThread :: ThreadId -> String -> IO ()
labelThread tid s = do
GHC.labelThread tid s
putStrLn $ "labelThread "++s++" "++show tid
modifyThreads $ Map.adjust (\pt -> pt { lbl = s }) tid
threadsInformation :: IO [PerThread]
threadsInformation = do
m <- threads <$> readMVar globals
return $ Map.elems m
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) }
r = f' g
threads r `seq` putMVar globals r
|
