diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-06 17:13:47 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-06 17:14:21 -0500 |
commit | 25ead19327a58e16fb82f22e20dbe910caf7a2a5 (patch) | |
tree | e1c6caf089b918c1ecefa7898696cebc0a60ae29 | |
parent | 62d31ca46fb3143af3004730195ff6554cf3fa40 (diff) |
Fixes to thread instrumentation.
-rw-r--r-- | lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs | 34 |
1 files changed, 24 insertions, 10 deletions
diff --git a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs index 2c35419e..afcb81ac 100644 --- a/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs +++ b/lifted-concurrent/src/Control/Concurrent/Lifted/Instrument.hs | |||
@@ -15,6 +15,7 @@ import qualified Control.Concurrent.Lifted as Raw | |||
15 | import Control.Concurrent.Lifted hiding (fork,forkOS) | 15 | import Control.Concurrent.Lifted hiding (fork,forkOS) |
16 | import Control.Exception (fromException) | 16 | import Control.Exception (fromException) |
17 | import Control.Monad.Trans.Control | 17 | import Control.Monad.Trans.Control |
18 | import GHC.Stack | ||
18 | import System.IO.Unsafe | 19 | import System.IO.Unsafe |
19 | import qualified Data.Map.Strict as Map | 20 | import qualified Data.Map.Strict as Map |
20 | import Control.Exception.Lifted | 21 | import Control.Exception.Lifted |
@@ -44,39 +45,48 @@ globals = unsafePerformIO $ newMVar $ GlobalState | |||
44 | } | 45 | } |
45 | {-# NOINLINE globals #-} | 46 | {-# NOINLINE globals #-} |
46 | 47 | ||
47 | forkLabeled :: String -> IO () -> IO ThreadId | 48 | forkLabeled :: HasCallStack => String -> IO () -> IO ThreadId |
48 | forkLabeled lbl action = do | 49 | forkLabeled lbl action = do |
49 | t <- forkIO action | 50 | t <- instrumented GHC.forkIO action |
50 | labelThread t lbl | 51 | labelThread t lbl |
51 | return t | 52 | return t |
52 | {-# INLINE forkLabeled #-} | 53 | {-# INLINE forkLabeled #-} |
53 | 54 | ||
54 | forkOSLabeled :: String -> IO () -> IO ThreadId | 55 | forkOSLabeled :: HasCallStack => String -> IO () -> IO ThreadId |
55 | forkOSLabeled lbl action = do | 56 | forkOSLabeled lbl action = do |
56 | t <- forkOS action | 57 | t <- instrumented Raw.forkOS action |
57 | labelThread t lbl | 58 | labelThread t lbl |
58 | return t | 59 | return t |
59 | {-# INLINE forkOSLabeled #-} | 60 | {-# INLINE forkOSLabeled #-} |
60 | 61 | ||
61 | forkIO :: IO () -> IO ThreadId | 62 | forkIO :: HasCallStack => IO () -> IO ThreadId |
62 | forkIO = instrumented GHC.forkIO | 63 | forkIO = instrumented GHC.forkIO |
63 | {-# INLINE forkIO #-} | 64 | {-# INLINE forkIO #-} |
64 | 65 | ||
65 | forkOS :: MonadBaseControl IO m => m () -> m ThreadId | 66 | forkOS :: ( HasCallStack, MonadBaseControl IO m ) => m () -> m ThreadId |
66 | forkOS = instrumented Raw.forkOS | 67 | forkOS = instrumented Raw.forkOS |
67 | {-# INLINE forkOS #-} | 68 | {-# INLINE forkOS #-} |
68 | 69 | ||
69 | fork :: MonadBaseControl IO m => m () -> m ThreadId | 70 | fork :: ( HasCallStack, MonadBaseControl IO m ) => m () -> m ThreadId |
70 | fork = instrumented Raw.fork | 71 | fork = instrumented Raw.fork |
71 | {-# INLINE fork #-} | 72 | {-# INLINE fork #-} |
72 | 73 | ||
73 | instrumented :: MonadBaseControl IO m => | 74 | shortCallStack :: [([Char], SrcLoc)] -> String |
75 | shortCallStack [] = "" | ||
76 | shortCallStack ((_,loc):_) = (srcLocFile loc) ++ ":" ++ show (srcLocStartLine loc) | ||
77 | |||
78 | defaultLabel :: CallStack -> String | ||
79 | defaultLabel stack = case getCallStack stack of | ||
80 | _ : sites -> shortCallStack sites | ||
81 | sites -> shortCallStack sites | ||
82 | |||
83 | instrumented :: ( HasCallStack, MonadBaseControl IO m ) => | ||
74 | (m () -> m ThreadId) -> m () -> m ThreadId | 84 | (m () -> m ThreadId) -> m () -> m ThreadId |
75 | instrumented rawFork action = do | 85 | instrumented rawFork action = do |
76 | t <- rawFork $ do | 86 | t <- rawFork $ do |
77 | tid <- myThreadId | 87 | tid <- myThreadId |
78 | tm <- liftBase getCurrentTime | 88 | tm <- liftBase getCurrentTime |
79 | bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm)) | 89 | bracket_ (modifyThreads $! \ts -> Map.union ts (Map.singleton tid (PerThread (defaultLabel callStack) tm))) |
80 | (return ()) | 90 | (return ()) |
81 | $ do catch action $ \e -> case fromException e of | 91 | $ do catch action $ \e -> case fromException e of |
82 | Just ThreadKilled -> return () | 92 | Just ThreadKilled -> return () |
@@ -99,12 +109,16 @@ instrumented rawFork action = do | |||
99 | reportException g l) | 109 | reportException g l) |
100 | -- Remove the thread only if it terminated normally or was killed. | 110 | -- Remove the thread only if it terminated normally or was killed. |
101 | modifyThreads $! Map.delete tid | 111 | modifyThreads $! Map.delete tid |
112 | liftBase $ labelThread t (defaultLabel callStack) | ||
102 | return t | 113 | return t |
103 | 114 | ||
104 | labelThread :: ThreadId -> String -> IO () | 115 | labelThread :: ThreadId -> String -> IO () |
105 | labelThread tid s = do | 116 | labelThread tid s = do |
106 | GHC.labelThread tid s | 117 | GHC.labelThread tid s |
107 | modifyThreads $! Map.adjust (\pt -> pt { lbl = s }) tid | 118 | tm <- liftBase getCurrentTime |
119 | let updateIt (Just pt) = Just $ pt { lbl = s } | ||
120 | updateIt Nothing = Just $ PerThread s tm | ||
121 | modifyThreads $! Map.alter updateIt tid | ||
108 | {-# INLINE labelThread #-} | 122 | {-# INLINE labelThread #-} |
109 | 123 | ||
110 | threadsInformation :: IO [(ThreadId,PerThread)] | 124 | threadsInformation :: IO [(ThreadId,PerThread)] |